/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.subobject.mono_over
import category_theory.skeletal
import tactic.elementwise
import tactic.apply_fun

/-!
# Subobjects

We define `subobject X` as the quotient (by isomorphisms) of
`mono_over X := {f : over X // mono f.hom}`.

Here `mono_over X` is a thin category (a pair of objects has at most one morphism between them),
so we can think of it as a preorder. However as it is not skeletal, it is not a partial order.

There is a coercion from `subobject X` back to the ambient category `C`
(using choice to pick a representative), and for `P : subobject X`,
`P.arrow : (P : C) ⟶ X` is the inclusion morphism.

We provide
* `def pullback [has_pullbacks C] (f : X ⟶ Y) : subobject Y ⥤ subobject X`
* `def map (f : X ⟶ Y) [mono f] : subobject X ⥤ subobject Y`
* `def «exists» [has_images C] (f : X ⟶ Y) : subobject X ⥤ subobject Y`
and prove their basic properties and relationships.
These are all easy consequences of the earlier development
of the corresponding functors for `mono_over`.

The subobjects of `X` form a preorder making them into a category. We have `X ≤ Y` if and only if
`X.arrow` factors through `Y.arrow`: see `of_le`/`of_le_mk`/`of_mk_le`/`of_mk_le_mk` and
`le_of_comm`. Similarly, to show that two subobjects are equal, we can supply an isomorphism between
the underlying objects that commutes with the arrows (`eq_of_comm`).

See also

* `category_theory.subobject.factor_thru` :
  an API describing factorization of morphisms through subobjects.
* `category_theory.subobject.lattice` :
  the lattice structures on subobjects.

## Notes

This development originally appeared in Bhavik Mehta's "Topos theory for Lean" repository,
and was ported to mathlib by Scott Morrison.

### Implementation note

Currently we describe `pullback`, `map`, etc., as functors.
It may be better to just say that they are monotone functions,
and even avoid using categorical language entirely when describing `subobject X`.
(It's worth keeping this in mind in future use; it should be a relatively easy change here
if it looks preferable.)

### Relation to pseudoelements

There is a separate development of pseudoelements in `category_theory.abelian.pseudoelements`,
as a quotient (but not by isomorphism) of `over X`.

When a morphism `f` has an image, the image represents the same pseudoelement.
In a category with images `pseudoelements X` could be constructed as a quotient of `mono_over X`.
In fact, in an abelian category (I'm not sure in what generality beyond that),
`pseudoelements X` agrees with `subobject X`, but we haven't developed this in mathlib yet.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory
namespace category_theory

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v₁} C] {X Y Z : C}
variables {D : Type u₂} [category.{v₂} D]

/-!
We now construct the subobject lattice for `X : C`,
as the quotient by isomorphisms of `mono_over X`.

Since `mono_over X` is a thin category, we use `thin_skeleton` to take the quotient.

Essentially all the structure defined above on `mono_over X` descends to `subobject X`,
with morphisms becoming inequalities, and isomorphisms becoming equations.
-/

/--
The category of subobjects of `X : C`, defined as isomorphism classes of monomorphisms into `X`.
-/
@[derive [partial_order, category]]
def subobject (X : C) := thin_skeleton (mono_over X)

namespace subobject

/-- Convenience constructor for a subobject. -/
abbreviation mk {X A : C} (f : A ⟶ X) [mono f] : subobject X :=
(to_thin_skeleton _).obj (mono_over.mk' f)

/-- The category of subobjects is equivalent to the `mono_over` category. It is more convenient to
use the former due to the partial order instance, but oftentimes it is easier to define structures
on the latter. -/
noncomputable def equiv_mono_over (X : C) : subobject X ≌ mono_over X :=
thin_skeleton.equivalence _

/--
Use choice to pick a representative `mono_over X` for each `subobject X`.
-/
noncomputable
def representative {X : C} : subobject X ⥤ mono_over X :=
(equiv_mono_over X).functor

/--
Starting with `A : mono_over X`, we can take its equivalence class in `subobject X`
then pick an arbitrary representative using `representative.obj`.
This is isomorphic (in `mono_over X`) to the original `A`.
-/
noncomputable
def representative_iso {X : C} (A : mono_over X) :
  representative.obj ((to_thin_skeleton _).obj A) ≅ A :=
(equiv_mono_over X).counit_iso.app A

/--
Use choice to pick a representative underlying object in `C` for any `subobject X`.

Prefer to use the coercion `P : C` rather than explicitly writing `underlying.obj P`.
-/
noncomputable
def underlying {X : C} : subobject X ⥤ C :=
representative ⋙ mono_over.forget _ ⋙ over.forget _

instance : has_coe (subobject X) C :=
{ coe := λ Y, underlying.obj Y, }

@[simp] lemma underlying_as_coe {X : C} (P : subobject X) : underlying.obj P = P := rfl

/--
If we construct a `subobject Y` from an explicit `f : X ⟶ Y` with `[mono f]`,
then pick an arbitrary choice of underlying object `(subobject.mk f : C)` back in `C`,
it is isomorphic (in `C`) to the original `X`.
-/
noncomputable
def underlying_iso {X Y : C} (f : X ⟶ Y) [mono f] : (subobject.mk f : C) ≅ X :=
(mono_over.forget _ ⋙ over.forget _).map_iso (representative_iso (mono_over.mk' f))

/--
The morphism in `C` from the arbitrarily chosen underlying object to the ambient object.
-/
noncomputable
def arrow {X : C} (Y : subobject X) : (Y : C) ⟶ X :=
(representative.obj Y).val.hom

instance arrow_mono {X : C} (Y : subobject X) : mono (Y.arrow) :=
(representative.obj Y).property

@[simp]
lemma arrow_congr {A : C} (X Y : subobject A) (h : X = Y) :
  eq_to_hom (congr_arg (λ X : subobject A, (X : C)) h) ≫ Y.arrow = X.arrow :=
by { induction h, simp, }

@[simp]
lemma representative_coe (Y : subobject X) :
  (representative.obj Y : C) = (Y : C) :=
rfl

@[simp]
lemma representative_arrow (Y : subobject X) :
  (representative.obj Y).arrow = Y.arrow :=
rfl

@[simp, reassoc]
lemma underlying_arrow {X : C} {Y Z : subobject X} (f : Y ⟶ Z) :
  underlying.map f ≫ arrow Z = arrow Y :=
over.w (representative.map f)

@[simp, reassoc, elementwise]
lemma underlying_iso_arrow {X Y : C} (f : X ⟶ Y) [mono f] :
  (underlying_iso f).inv ≫ (subobject.mk f).arrow = f :=
over.w _

@[simp, reassoc]
lemma underlying_iso_hom_comp_eq_mk {X Y : C} (f : X ⟶ Y) [mono f] :
  (underlying_iso f).hom ≫ f = (mk f).arrow :=
(iso.eq_inv_comp _).1 (underlying_iso_arrow f).symm

/-- Two morphisms into a subobject are equal exactly if
the morphisms into the ambient object are equal -/
@[ext]
lemma eq_of_comp_arrow_eq {X Y : C} {P : subobject Y}
  {f g : X ⟶ P} (h : f ≫ P.arrow = g ≫ P.arrow) : f = g :=
(cancel_mono P.arrow).mp h

lemma mk_le_mk_of_comm {B A₁ A₂ : C} {f₁ : A₁ ⟶ B} {f₂ : A₂ ⟶ B} [mono f₁] [mono f₂] (g : A₁ ⟶ A₂)
  (w : g ≫ f₂ = f₁) : mk f₁ ≤ mk f₂ :=
⟨mono_over.hom_mk _ w⟩

@[simp] lemma mk_arrow (P : subobject X) : mk P.arrow = P :=
quotient.induction_on' P $ λ Q,
begin
  obtain ⟨e⟩ := @quotient.mk_out' _ (is_isomorphic_setoid _) Q,
  refine quotient.sound' ⟨mono_over.iso_mk _ _ ≪≫ e⟩;
  tidy
end

lemma le_of_comm {B : C} {X Y : subobject B} (f : (X : C) ⟶ (Y : C)) (w : f ≫ Y.arrow = X.arrow) :
  X ≤ Y :=
by convert mk_le_mk_of_comm _ w; simp

lemma le_mk_of_comm {B A : C} {X : subobject B} {f : A ⟶ B} [mono f] (g : (X : C) ⟶ A)
  (w : g ≫ f = X.arrow) : X ≤ mk f :=
le_of_comm (g ≫ (underlying_iso f).inv) $ by simp [w]

lemma mk_le_of_comm {B A : C} {X : subobject B} {f : A ⟶ B} [mono f] (g : A ⟶ (X : C))
  (w : g ≫ X.arrow = f) : mk f ≤ X :=
le_of_comm ((underlying_iso f).hom ≫ g) $ by simp [w]

/-- To show that two subobjects are equal, it suffices to exhibit an isomorphism commuting with
    the arrows. -/
@[ext] lemma eq_of_comm {B : C} {X Y : subobject B} (f : (X : C) ≅ (Y : C))
  (w : f.hom ≫ Y.arrow = X.arrow) : X = Y :=
le_antisymm (le_of_comm f.hom w) $ le_of_comm f.inv $ f.inv_comp_eq.2 w.symm

/-- To show that two subobjects are equal, it suffices to exhibit an isomorphism commuting with
    the arrows. -/
@[ext] lemma eq_mk_of_comm {B A : C} {X : subobject B} (f : A ⟶ B) [mono f] (i : (X : C) ≅ A)
  (w : i.hom ≫ f = X.arrow) : X = mk f :=
eq_of_comm (i.trans (underlying_iso f).symm) $ by simp [w]

/-- To show that two subobjects are equal, it suffices to exhibit an isomorphism commuting with
    the arrows. -/
@[ext] lemma mk_eq_of_comm {B A : C} {X : subobject B} (f : A ⟶ B) [mono f] (i : A ≅ (X : C))
  (w : i.hom ≫ X.arrow = f) : mk f = X :=
eq.symm $ eq_mk_of_comm _ i.symm $ by rw [iso.symm_hom, iso.inv_comp_eq, w]

/-- To show that two subobjects are equal, it suffices to exhibit an isomorphism commuting with
    the arrows. -/
@[ext] lemma mk_eq_mk_of_comm {B A₁ A₂ : C} (f : A₁ ⟶ B) (g : A₂ ⟶ B) [mono f] [mono g]
  (i : A₁ ≅ A₂) (w : i.hom ≫ g = f) : mk f = mk g :=
eq_mk_of_comm _ ((underlying_iso f).trans i) $ by simp [w]

/-- An inequality of subobjects is witnessed by some morphism between the corresponding objects. -/
-- We make `X` and `Y` explicit arguments here so that when `of_le` appears in goal statements
-- it is possible to see its source and target
-- (`h` will just display as `_`, because it is in `Prop`).
def of_le {B : C} (X Y : subobject B) (h : X ≤ Y) : (X : C) ⟶ (Y : C) :=
underlying.map $ h.hom

@[simp, reassoc] lemma of_le_arrow {B : C} {X Y : subobject B} (h : X ≤ Y) :
  of_le X Y h ≫ Y.arrow = X.arrow :=
underlying_arrow _

instance {B : C} (X Y : subobject B) (h : X ≤ Y) : mono (of_le X Y h) :=
begin
  fsplit,
  intros Z f g w,
  replace w := w =≫ Y.arrow,
  ext,
  simpa using w,
end

lemma of_le_mk_le_mk_of_comm
  {B A₁ A₂ : C} {f₁ : A₁ ⟶ B} {f₂ : A₂ ⟶ B} [mono f₁] [mono f₂] (g : A₁ ⟶ A₂) (w : g ≫ f₂ = f₁) :
  of_le _ _ (mk_le_mk_of_comm g w) = (underlying_iso _).hom ≫ g ≫ (underlying_iso _).inv :=
by { ext, simp [w], }

/-- An inequality of subobjects is witnessed by some morphism between the corresponding objects. -/
@[derive mono]
def of_le_mk {B A : C} (X : subobject B) (f : A ⟶ B) [mono f] (h : X ≤ mk f) : (X : C) ⟶ A :=
of_le X (mk f) h ≫ (underlying_iso f).hom

@[simp] lemma of_le_mk_comp {B A : C} {X : subobject B} {f : A ⟶ B} [mono f] (h : X ≤ mk f) :
  of_le_mk X f h ≫ f = X.arrow :=
by simp [of_le_mk]

/-- An inequality of subobjects is witnessed by some morphism between the corresponding objects. -/
@[derive mono]
def of_mk_le {B A : C} (f : A ⟶ B) [mono f] (X : subobject B) (h : mk f ≤ X) : A ⟶ (X : C) :=
(underlying_iso f).inv ≫ of_le (mk f) X h

@[simp] lemma of_mk_le_arrow {B A : C} {f : A ⟶ B} [mono f] {X : subobject B} (h : mk f ≤ X) :
  of_mk_le f X h ≫ X.arrow = f :=
by simp [of_mk_le]

/-- An inequality of subobjects is witnessed by some morphism between the corresponding objects. -/
@[derive mono]
def of_mk_le_mk {B A₁ A₂ : C} (f : A₁ ⟶ B) (g : A₂ ⟶ B) [mono f] [mono g] (h : mk f ≤ mk g) :
  A₁ ⟶ A₂ :=
(underlying_iso f).inv ≫ of_le (mk f) (mk g) h ≫ (underlying_iso g).hom

@[simp] lemma of_mk_le_mk_comp {B A₁ A₂ : C} {f : A₁ ⟶ B} {g : A₂ ⟶ B} [mono f] [mono g]
  (h : mk f ≤ mk g) : of_mk_le_mk f g h ≫ g = f :=
by simp [of_mk_le_mk]

@[simp, reassoc] lemma of_le_comp_of_le {B : C} (X Y Z : subobject B) (h₁ : X ≤ Y) (h₂ : Y ≤ Z) :
  of_le X Y h₁ ≫ of_le Y Z h₂ = of_le X Z (h₁.trans h₂) :=
by simp [of_le, ←functor.map_comp underlying]

@[simp, reassoc] lemma of_le_comp_of_le_mk {B A : C} (X Y : subobject B) (f : A ⟶ B) [mono f]
  (h₁ : X ≤ Y) (h₂ : Y ≤ mk f) : of_le X Y h₁ ≫ of_le_mk Y f h₂ = of_le_mk X f (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, ←functor.map_comp_assoc underlying]

@[simp, reassoc] lemma of_le_mk_comp_of_mk_le {B A : C} (X : subobject B) (f : A ⟶ B) [mono f]
  (Y : subobject B) (h₁ : X ≤ mk f) (h₂ : mk f ≤ Y) :
  of_le_mk X f h₁ ≫ of_mk_le f Y h₂ = of_le X Y (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, ←functor.map_comp underlying]

@[simp, reassoc] lemma of_le_mk_comp_of_mk_le_mk {B A₁ A₂ : C} (X : subobject B) (f : A₁ ⟶ B)
  [mono f] (g : A₂ ⟶ B) [mono g] (h₁ : X ≤ mk f) (h₂ : mk f ≤ mk g) :
  of_le_mk X f h₁ ≫ of_mk_le_mk f g h₂ = of_le_mk X g (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp_assoc underlying]

@[simp, reassoc] lemma of_mk_le_comp_of_le {B A₁ : C} (f : A₁ ⟶ B) [mono f] (X Y : subobject B)
  (h₁ : mk f ≤ X) (h₂ : X ≤ Y) :
  of_mk_le f X h₁ ≫ of_le X Y h₂ = of_mk_le f Y (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp underlying]

@[simp, reassoc] lemma of_mk_le_comp_of_le_mk {B A₁ A₂ : C} (f : A₁ ⟶ B) [mono f] (X : subobject B)
  (g : A₂ ⟶ B) [mono g] (h₁ : mk f ≤ X) (h₂ : X ≤ mk g) :
  of_mk_le f X h₁ ≫ of_le_mk X g h₂ = of_mk_le_mk f g (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp_assoc underlying]

@[simp, reassoc] lemma of_mk_le_mk_comp_of_mk_le {B A₁ A₂ : C} (f : A₁ ⟶ B) [mono f] (g : A₂ ⟶ B)
  [mono g] (X : subobject B) (h₁ : mk f ≤ mk g) (h₂ : mk g ≤ X) :
  of_mk_le_mk f g h₁ ≫ of_mk_le g X h₂ = of_mk_le f X (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp underlying]

@[simp, reassoc] lemma of_mk_le_mk_comp_of_mk_le_mk {B A₁ A₂ A₃ : C} (f : A₁ ⟶ B) [mono f]
  (g : A₂ ⟶ B) [mono g] (h : A₃ ⟶ B) [mono h] (h₁ : mk f ≤ mk g) (h₂ : mk g ≤ mk h) :
  of_mk_le_mk f g h₁ ≫ of_mk_le_mk g h h₂ = of_mk_le_mk f h (h₁.trans h₂) :=
by simp [of_mk_le, of_le_mk, of_le, of_mk_le_mk, ←functor.map_comp_assoc underlying]

@[simp] lemma of_le_refl {B : C} (X : subobject B) :
  of_le X X le_rfl = 𝟙 _ :=
by { apply (cancel_mono X.arrow).mp, simp }

@[simp] lemma of_mk_le_mk_refl {B A₁ : C} (f : A₁ ⟶ B) [mono f] :
  of_mk_le_mk f f le_rfl = 𝟙 _ :=
by { apply (cancel_mono f).mp, simp }

/-- An equality of subobjects gives an isomorphism of the corresponding objects.
(One could use `underlying.map_iso (eq_to_iso h))` here, but this is more readable.) -/
-- As with `of_le`, we have `X` and `Y` as explicit arguments for readability.
@[simps]
def iso_of_eq {B : C} (X Y : subobject B) (h : X = Y) : (X : C) ≅ (Y : C) :=
{ hom := of_le _ _ h.le,
  inv := of_le _ _ h.ge, }

/-- An equality of subobjects gives an isomorphism of the corresponding objects. -/
@[simps]
def iso_of_eq_mk {B A : C} (X : subobject B) (f : A ⟶ B) [mono f] (h : X = mk f) : (X : C) ≅ A :=
{ hom := of_le_mk X f h.le,
  inv := of_mk_le f X h.ge }

/-- An equality of subobjects gives an isomorphism of the corresponding objects. -/
@[simps]
def iso_of_mk_eq {B A : C} (f : A ⟶ B) [mono f] (X : subobject B) (h : mk f = X) : A ≅ (X : C) :=
{ hom := of_mk_le f X h.le,
  inv := of_le_mk X f h.ge, }

/-- An equality of subobjects gives an isomorphism of the corresponding objects. -/
@[simps]
def iso_of_mk_eq_mk {B A₁ A₂ : C} (f : A₁ ⟶ B) (g : A₂ ⟶ B) [mono f] [mono g] (h : mk f = mk g) :
  A₁ ≅ A₂ :=
{ hom := of_mk_le_mk f g h.le,
  inv := of_mk_le_mk g f h.ge, }

end subobject

open category_theory.limits

namespace subobject

/-- Any functor `mono_over X ⥤ mono_over Y` descends to a functor
`subobject X ⥤ subobject Y`, because `mono_over Y` is thin. -/
def lower {Y : D} (F : mono_over X ⥤ mono_over Y) : subobject X ⥤ subobject Y :=
thin_skeleton.map F

/-- Isomorphic functors become equal when lowered to `subobject`.
(It's not as evil as usual to talk about equality between functors
because the categories are thin and skeletal.) -/
lemma lower_iso (F₁ F₂ : mono_over X ⥤ mono_over Y) (h : F₁ ≅ F₂) :
  lower F₁ = lower F₂ :=
thin_skeleton.map_iso_eq h

/-- A ternary version of `subobject.lower`. -/
def lower₂ (F : mono_over X ⥤ mono_over Y ⥤ mono_over Z) :
  subobject X ⥤ subobject Y ⥤ subobject Z :=
thin_skeleton.map₂ F

@[simp]

/-- An adjunction between `mono_over A` and `mono_over B` gives an adjunction
between `subobject A` and `subobject B`. -/
def lower_adjunction {A : C} {B : D}
  {L : mono_over A ⥤ mono_over B} {R : mono_over B ⥤ mono_over A} (h : L ⊣ R) :
  lower L ⊣ lower R :=
thin_skeleton.lower_adjunction _ _ h

/-- An equivalence between `mono_over A` and `mono_over B` gives an equivalence
between `subobject A` and `subobject B`. -/
@[simps]
def lower_equivalence {A : C} {B : D} (e : mono_over A ≌ mono_over B) : subobject A ≌ subobject B :=
{ functor := lower e.functor,
  inverse := lower e.inverse,
  unit_iso :=
  begin
    apply eq_to_iso,
    convert thin_skeleton.map_iso_eq e.unit_iso,
    { exact thin_skeleton.map_id_eq.symm },
    { exact (thin_skeleton.map_comp_eq _ _).symm },
  end,
  counit_iso :=
  begin
    apply eq_to_iso,
    convert thin_skeleton.map_iso_eq e.counit_iso,
    { exact (thin_skeleton.map_comp_eq _ _).symm },
    { exact thin_skeleton.map_id_eq.symm },
  end }

section pullback
variables [has_pullbacks C]

/-- When `C` has pullbacks, a morphism `f : X ⟶ Y` induces a functor `subobject Y ⥤ subobject X`,
by pulling back a monomorphism along `f`. -/
def pullback (f : X ⟶ Y) : subobject Y ⥤ subobject X :=
lower (mono_over.pullback f)

lemma pullback_id (x : subobject X) : (pullback (𝟙 X)).obj x = x :=
begin
  apply quotient.induction_on' x,
  intro f,
  apply quotient.sound,
  exact ⟨mono_over.pullback_id.app f⟩,
end

lemma pullback_comp (f : X ⟶ Y) (g : Y ⟶ Z) (x : subobject Z) :
  (pullback (f ≫ g)).obj x = (pullback f).obj ((pullback g).obj x) :=
begin
  apply quotient.induction_on' x,
  intro t,
  apply quotient.sound,
  refine ⟨(mono_over.pullback_comp _ _).app t⟩,
end

instance (f : X ⟶ Y) : faithful (pullback f) := {}

end pullback

section map

/--
We can map subobjects of `X` to subobjects of `Y`
by post-composition with a monomorphism `f : X ⟶ Y`.
-/
def map (f : X ⟶ Y) [mono f] : subobject X ⥤ subobject Y :=
lower (mono_over.map f)

lemma map_id (x : subobject X) : (map (𝟙 X)).obj x = x :=
begin
  apply quotient.induction_on' x,
  intro f,
  apply quotient.sound,
  exact ⟨mono_over.map_id.app f⟩,
end

lemma map_comp (f : X ⟶ Y) (g : Y ⟶ Z) [mono f] [mono g] (x : subobject X) :
  (map (f ≫ g)).obj x = (map g).obj ((map f).obj x) :=
begin
  apply quotient.induction_on' x,
  intro t,
  apply quotient.sound,
  refine ⟨(mono_over.map_comp _ _).app t⟩,
end

/-- Isomorphic objects have equivalent subobject lattices. -/
def map_iso {A B : C} (e : A ≅ B) : subobject A ≌ subobject B :=
lower_equivalence (mono_over.map_iso e)

/-- In fact, there's a type level bijection between the subobjects of isomorphic objects,
which preserves the order. -/
-- @[simps] here generates a lemma `map_iso_to_order_iso_to_equiv_symm_apply`
-- whose left hand side is not in simp normal form.
def map_iso_to_order_iso (e : X ≅ Y) : subobject X ≃o subobject Y :=
{ to_fun := (map e.hom).obj,
  inv_fun := (map e.inv).obj,
  left_inv := λ g, by simp_rw [← map_comp, e.hom_inv_id, map_id],
  right_inv := λ g, by simp_rw [← map_comp, e.inv_hom_id, map_id],
  map_rel_iff' := λ A B, begin
    dsimp, fsplit,
    { intro h,
      apply_fun (map e.inv).obj at h,
      simp_rw [← map_comp, e.hom_inv_id, map_id] at h,
      exact h, },
    { intro h,
      apply_fun (map e.hom).obj at h,
      exact h, },
  end }

@[simp] lemma map_iso_to_order_iso_apply (e : X ≅ Y) (P : subobject X) :
  map_iso_to_order_iso e P = (map e.hom).obj P :=
rfl

@[simp] lemma map_iso_to_order_iso_symm_apply (e : X ≅ Y) (Q : subobject Y) :
  (map_iso_to_order_iso e).symm Q = (map e.inv).obj Q :=
rfl

/-- `map f : subobject X ⥤ subobject Y` is
the left adjoint of `pullback f : subobject Y ⥤ subobject X`. -/
def map_pullback_adj [has_pullbacks C] (f : X ⟶ Y) [mono f] : map f ⊣ pullback f :=
lower_adjunction (mono_over.map_pullback_adj f)

@[simp]
lemma pullback_map_self [has_pullbacks C] (f : X ⟶ Y) [mono f] (g : subobject X) :
  (pullback f).obj ((map f).obj g) = g :=
begin
  revert g,
  apply quotient.ind,
  intro g',
  apply quotient.sound,
  exact ⟨(mono_over.pullback_map_self f).app _⟩,
end

lemma map_pullback [has_pullbacks C]
  {X Y Z W : C} {f : X ⟶ Y} {g : X ⟶ Z} {h : Y ⟶ W} {k : Z ⟶ W} [mono h] [mono g]
  (comm : f ≫ h = g ≫ k) (t : is_limit (pullback_cone.mk f g comm)) (p : subobject Y) :
  (map g).obj ((pullback f).obj p) = (pullback k).obj ((map h).obj p) :=
begin
  revert p,
  apply quotient.ind',
  intro a,
  apply quotient.sound,
  apply thin_skeleton.equiv_of_both_ways,
  { refine mono_over.hom_mk (pullback.lift pullback.fst _ _) (pullback.lift_snd _ _ _),
    change _ ≫ a.arrow ≫ h = (pullback.snd ≫ g) ≫ _,
    rw [assoc, ← comm, pullback.condition_assoc] },
  { refine mono_over.hom_mk (pullback.lift pullback.fst
                        (pullback_cone.is_limit.lift' t (pullback.fst ≫ a.arrow) pullback.snd _).1
                        (pullback_cone.is_limit.lift' _ _ _ _).2.1.symm) _,
    { rw [← pullback.condition, assoc], refl },
    { dsimp, rw [pullback.lift_snd_assoc],
      apply (pullback_cone.is_limit.lift' _ _ _ _).2.2 } }
end

end map

section «exists»
variables [has_images C]

/--
The functor from subobjects of `X` to subobjects of `Y` given by
sending the subobject `S` to its "image" under `f`, usually denoted $\exists_f$.
For instance, when `C` is the category of types,
viewing `subobject X` as `set X` this is just `set.image f`.

This functor is left adjoint to the `pullback f` functor (shown in `exists_pullback_adj`)
provided both are defined, and generalises the `map f` functor, again provided it is defined.
-/
def «exists» (f : X ⟶ Y) : subobject X ⥤ subobject Y :=
lower (mono_over.exists f)

/--
When `f : X ⟶ Y` is a monomorphism, `exists f` agrees with `map f`.
-/
lemma exists_iso_map (f : X ⟶ Y) [mono f] : «exists» f = map f :=
lower_iso _ _ (mono_over.exists_iso_map f)

/--
`exists f : subobject X ⥤ subobject Y` is
left adjoint to `pullback f : subobject Y ⥤ subobject X`.
-/
def exists_pullback_adj (f : X ⟶ Y) [has_pullbacks C] : «exists» f ⊣ pullback f :=
lower_adjunction (mono_over.exists_pullback_adj f)

end  «exists»

end subobject

end category_theory


/-
    Stalk of rings on basis.

    https://stacks.math.columbia.edu/tag/007L
    (just says that the category of rings is a type of algebraic structure)
-/

import to_mathlib.opens
import topology.basic
import sheaves.stalk_on_basis
import sheaves.presheaf_of_rings_on_basis

universe u

open topological_space

namespace stalk_of_rings_on_standard_basis

variables {α : Type u} [topological_space α]
variables {B : set (opens α )} {HB : opens.is_basis B}

-- Standard basis. TODO: Move somewhere else?

variables (Bstd : opens.univ ∈ B ∧ ∀ {U V}, U ∈ B → V ∈ B → U ∩ V ∈ B)

variables (F : presheaf_of_rings_on_basis α HB) (x : α)

include Bstd

definition stalk_of_rings_on_standard_basis :=
stalk_on_basis F.to_presheaf_on_basis x

section stalk_of_rings_on_standard_basis_is_ring

open stalk_of_rings_on_standard_basis

-- Add.

protected def add_aux :
stalk_on_basis.elem F.to_presheaf_on_basis x →
stalk_on_basis.elem F.to_presheaf_on_basis x →
stalk_on_basis F.to_presheaf_on_basis x :=
λ s t,
⟦{U := s.U ∩ t.U,
BU := Bstd.2 s.BU t.BU,
Hx := ⟨s.Hx, t.Hx⟩,
s := F.res s.BU _ (set.inter_subset_left _ _) s.s +
     F.res t.BU _ (set.inter_subset_right _ _) t.s}⟧

instance has_add : has_add (stalk_of_rings_on_standard_basis Bstd F x) :=
{ add := quotient.lift₂ (stalk_of_rings_on_standard_basis.add_aux Bstd F x) $
    begin
      intros a1 a2 b1 b2 H1 H2,
      let F' := F.to_presheaf_on_basis,
      rcases H1 with ⟨U1, ⟨BU1, ⟨HxU1, ⟨HU1a1U, HU1b1U, HresU1⟩⟩⟩⟩,
      rcases H2 with ⟨U2, ⟨BU2, ⟨HxU2, ⟨HU2a2U, HU2b2U, HresU2⟩⟩⟩⟩,
      have BU1U2 := Bstd.2 BU1 BU2,
      apply quotient.sound,
      use [U1 ∩ U2, BU1U2, ⟨HxU1, HxU2⟩],
      use [set.inter_subset_inter HU1a1U HU2a2U, set.inter_subset_inter HU1b1U HU2b2U],
      repeat { rw (F.res_is_ring_hom _ _ _).map_add },
      have HresU1' :
          (F'.res BU1 BU1U2 (set.inter_subset_left _ _) ((F'.res a1.BU BU1 HU1a1U) (a1.s))) =
          (F'.res BU1 BU1U2 (set.inter_subset_left _ _) ((F'.res b1.BU BU1 HU1b1U) (b1.s)))
      := by rw HresU1,
      have HresU2' :
          (F'.res BU2 BU1U2 (set.inter_subset_right _ _) ((F'.res a2.BU BU2 HU2a2U) (a2.s))) =
          (F'.res BU2 BU1U2 (set.inter_subset_right _ _) ((F'.res b2.BU BU2 HU2b2U) (b2.s)))
      := by rw HresU2,
      repeat { rw ←(presheaf_on_basis.Hcomp' F') at HresU1' },
      repeat { rw ←(presheaf_on_basis.Hcomp' F') at HresU2' },
      repeat { rw ←(presheaf_on_basis.Hcomp' F') },
      rw [HresU1', HresU2'],
    end }

@[simp] lemma has_add.mk : ∀ y z,
  (⟦y⟧ + ⟦z⟧ : stalk_of_rings_on_standard_basis Bstd F x) =
  (stalk_of_rings_on_standard_basis.add_aux Bstd F x) y z :=
λ y z, rfl

instance add_semigroup : add_semigroup (stalk_of_rings_on_standard_basis Bstd F x) :=
{ add_assoc :=
    begin
      intros a b c,
      refine quotient.induction_on₃ a b c _,
      rintros ⟨U, BU, HxU, sU⟩ ⟨V, BV, HxV, sV⟩ ⟨W, BW, HxW, sW⟩,
      have BUVW := Bstd.2 (Bstd.2 BU BV) BW,
      have HUVWsub : U ∩ V ∩ W ⊆ U ∩ (V ∩ W)
      := λ x ⟨⟨HxU, HxV⟩, HxW⟩, ⟨HxU, ⟨HxV, HxW⟩⟩,
      apply quotient.sound,
      use [U ∩ V ∩ W, BUVW, ⟨⟨HxU, HxV⟩, HxW⟩],
      use [set.subset.refl _, HUVWsub],
      dsimp,
      repeat { rw (F.res_is_ring_hom _ _ _).map_add },
      repeat { erw ←presheaf_on_basis.Hcomp' },
      rw add_assoc,
    end,
  ..stalk_of_rings_on_standard_basis.has_add Bstd F x }

instance add_comm_semigroup : add_comm_semigroup (stalk_of_rings_on_standard_basis Bstd F x) :=
{ add_comm :=
    begin
      intros a b,
      refine quotient.induction_on₂ a b _,
      rintros ⟨U, BU, HxU, sU⟩ ⟨V, BV, HxV, sV⟩,
      apply quotient.sound,
      have BUV : U ∩ V ∈ B := Bstd.2 BU BV,
      have HUVUV : U ∩ V ⊆ U ∩ V := λ x HxUV, HxUV,
      have HUVVU : U ∩ V ⊆ V ∩ U := λ x ⟨HxU, HxV⟩, ⟨HxV, HxU⟩,
      use [U ∩ V, BUV, ⟨HxU, HxV⟩, HUVUV, HUVVU],
      repeat { rw (F.res_is_ring_hom _ _ _).map_add },
      repeat { rw ←presheaf_on_basis.Hcomp' },
      rw add_comm,
    end,
  ..stalk_of_rings_on_standard_basis.add_semigroup Bstd F x }

-- Zero.

protected def zero : stalk_of_rings_on_standard_basis Bstd F x :=
⟦{U := opens.univ, BU := Bstd.1, Hx := trivial, s:= 0}⟧

instance has_zero : has_zero (stalk_of_rings_on_standard_basis Bstd F x) :=
{ zero := stalk_of_rings_on_standard_basis.zero Bstd F x }

instance add_comm_monoid : add_comm_monoid (stalk_of_rings_on_standard_basis Bstd F x) :=
{ zero_add :=
    begin
      intros a,
      refine quotient.induction_on a _,
      rintros ⟨U, BU, HxU, sU⟩,
      apply quotient.sound,
      have HUsub : U ⊆ opens.univ ∩ U := λ x HxU, ⟨trivial, HxU⟩,
      use [U, BU, HxU, HUsub, set.subset.refl U],
      repeat { rw (F.res_is_ring_hom _ _ _).map_add },
      repeat { rw ←presheaf_on_basis.Hcomp' },
      erw (is_ring_hom.map_zero ((F.to_presheaf_on_basis).res _ _ _));
      try { apply_instance },
      rw zero_add,
      refl,
    end,
  add_zero :=
    begin
      intros a,
      refine quotient.induction_on a _,
      rintros ⟨U, BU, HxU, sU⟩,
      apply quotient.sound,
      have HUsub : U ⊆ U ∩ opens.univ := λ x HxU, ⟨HxU, trivial⟩,
      use [U, BU, HxU, HUsub, set.subset.refl U],
      repeat { rw (F.res_is_ring_hom _ _ _).map_add },
      repeat { rw ←presheaf_on_basis.Hcomp' },
      dsimp,
      erw (is_ring_hom.map_zero ((F.to_presheaf_on_basis).res _ _ _));
      try { apply_instance },
      rw add_zero,
      refl,
    end,
  ..stalk_of_rings_on_standard_basis.has_zero Bstd F x,
  ..stalk_of_rings_on_standard_basis.add_comm_semigroup Bstd F x }

-- Neg.

protected def neg_aux :
stalk_on_basis.elem F.to_presheaf_on_basis x →
stalk_on_basis F.to_presheaf_on_basis x :=
λ s, ⟦{U := s.U, BU := s.BU, Hx := s.Hx, s := -s.s}⟧

instance has_neg : has_neg (stalk_of_rings_on_standard_basis Bstd F x) :=
{ neg := quotient.lift (stalk_of_rings_on_standard_basis.neg_aux Bstd F x) $
  begin
    intros a b H,
    rcases H with ⟨U, ⟨BU, ⟨HxU, ⟨HUaU, HUbU, HresU⟩⟩⟩⟩,
    apply quotient.sound,
    use [U, BU, HxU, HUaU, HUbU],
    repeat { rw @is_ring_hom.map_neg _ _ _ _ _ (F.res_is_ring_hom _ _ _) },
    rw HresU,
  end }

instance add_comm_group : add_comm_group (stalk_of_rings_on_standard_basis Bstd F x) :=
{ add_left_neg :=
    begin
      intros a,
      refine quotient.induction_on a _,
      rintros ⟨U, BU, HxU, sU⟩,
      apply quotient.sound,
      have HUUU : U ⊆ U ∩ U := λ x HxU, ⟨HxU, HxU⟩,
      have HUuniv : U ⊆ opens.univ := λ x HxU, trivial,
      use [U, BU, HxU, HUUU, HUuniv],
      repeat { rw (F.res_is_ring_hom _ _ _).map_add },
      repeat { rw ←presheaf_on_basis.Hcomp' },
      erw (is_ring_hom.map_neg ((F.to_presheaf_on_basis).res _ _ _));
      try { apply_instance },
      rw add_left_neg,
      erw (is_ring_hom.map_zero ((F.to_presheaf_on_basis).res _ _ _));
      try { apply_instance },
    end,
  ..stalk_of_rings_on_standard_basis.has_neg Bstd F x,
  ..stalk_of_rings_on_standard_basis.add_comm_monoid Bstd F x, }

-- Mul.

protected def mul_aux :
stalk_on_basis.elem F.to_presheaf_on_basis x →
stalk_on_basis.elem F.to_presheaf_on_basis x →
stalk_on_basis F.to_presheaf_on_basis x :=
λ s t,
⟦{U := s.U ∩ t.U,
BU := Bstd.2 s.BU t.BU,
Hx := ⟨s.Hx, t.Hx⟩,
s := F.res s.BU _ (set.inter_subset_left _ _) s.s *
     F.res t.BU _ (set.inter_subset_right _ _) t.s}⟧

instance has_mul : has_mul (stalk_of_rings_on_standard_basis Bstd F x) :=
{ mul := quotient.lift₂ (stalk_of_rings_on_standard_basis.mul_aux Bstd F x) $
    begin
      intros a1 a2 b1 b2 H1 H2,
      let F' := F.to_presheaf_on_basis,
      rcases H1 with ⟨U1, ⟨BU1, ⟨HxU1, ⟨HU1a1U, HU1b1U, HresU1⟩⟩⟩⟩,
      rcases H2 with ⟨U2, ⟨BU2, ⟨HxU2, ⟨HU2a2U, HU2b2U, HresU2⟩⟩⟩⟩,
      have BU1U2 := Bstd.2 BU1 BU2,
      apply quotient.sound,
      use [U1 ∩ U2, BU1U2, ⟨HxU1, HxU2⟩],
      use [set.inter_subset_inter HU1a1U HU2a2U, set.inter_subset_inter HU1b1U HU2b2U],
      repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
      have HresU1' :
          (F'.res BU1 BU1U2 (set.inter_subset_left _ _) ((F'.res a1.BU BU1 HU1a1U) (a1.s))) =
          (F'.res BU1 BU1U2 (set.inter_subset_left _ _) ((F'.res b1.BU BU1 HU1b1U) (b1.s)))
      := by rw HresU1,
      have HresU2' :
          (F'.res BU2 BU1U2 (set.inter_subset_right _ _) ((F'.res a2.BU BU2 HU2a2U) (a2.s))) =
          (F'.res BU2 BU1U2 (set.inter_subset_right _ _) ((F'.res b2.BU BU2 HU2b2U) (b2.s)))
      := by rw HresU2,
      repeat { rw ←(presheaf_on_basis.Hcomp' F') at HresU1' },
      repeat { rw ←(presheaf_on_basis.Hcomp' F') at HresU2' },
      repeat { rw ←(presheaf_on_basis.Hcomp' F') },
      rw [HresU1', HresU2'],
    end}

@[simp] lemma has_mul.mk : ∀ y z,
  (⟦y⟧ * ⟦z⟧ : stalk_of_rings_on_standard_basis Bstd F x) =
  (stalk_of_rings_on_standard_basis.mul_aux Bstd F x) y z :=
λ y z, rfl

instance mul_semigroup : semigroup (stalk_of_rings_on_standard_basis Bstd F x) :=
{ mul_assoc :=
    begin
      intros a b c,
      refine quotient.induction_on₃ a b c _,
      rintros ⟨U, BU, HxU, sU⟩ ⟨V, BV, HxV, sV⟩ ⟨W, BW, HxW, sW⟩,
      have BUVW := Bstd.2 (Bstd.2 BU BV) BW,
      have HUVWsub : U ∩ V ∩ W ⊆ U ∩ (V ∩ W)
      := λ x ⟨⟨HxU, HxV⟩, HxW⟩, ⟨HxU, ⟨HxV, HxW⟩⟩,
      apply quotient.sound,
      use [U ∩ V ∩ W, BUVW, ⟨⟨HxU, HxV⟩, HxW⟩],
      use [set.subset.refl _, HUVWsub],
      repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
      repeat { rw ←presheaf_on_basis.Hcomp' },
      rw mul_assoc,
    end,
  ..stalk_of_rings_on_standard_basis.has_mul Bstd F x }

instance mul_comm_semigroup : comm_semigroup (stalk_of_rings_on_standard_basis Bstd F x) :=
{ mul_comm :=
    begin
      intros a b,
      refine quotient.induction_on₂ a b _,
      rintros ⟨U, BU, HxU, sU⟩ ⟨V, BV, HxV, sV⟩,
      apply quotient.sound,
      have BUV : U ∩ V ∈ B := Bstd.2 BU BV,
      have HUVUV : U ∩ V ⊆ U ∩ V := λ x HxUV, HxUV,
      have HUVVU : U ∩ V ⊆ V ∩ U := λ x ⟨HxU, HxV⟩, ⟨HxV, HxU⟩,
      use [U ∩ V, BUV, ⟨HxU, HxV⟩, HUVUV, HUVVU],
      repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
      repeat { rw ←presheaf_on_basis.Hcomp' },
      rw mul_comm,
    end,
  ..stalk_of_rings_on_standard_basis.mul_semigroup Bstd F x }

-- One.

protected def one : stalk_of_rings_on_standard_basis Bstd F x :=
⟦{U := opens.univ, BU := Bstd.1, Hx := trivial, s:= 1}⟧

instance has_one : has_one (stalk_of_rings_on_standard_basis Bstd F x) :=
{ one := stalk_of_rings_on_standard_basis.one Bstd F x }

instance mul_comm_monoid : comm_monoid (stalk_of_rings_on_standard_basis Bstd F x) :=
{ one_mul :=
    begin
      intros a,
      refine quotient.induction_on a _,
      rintros ⟨U, BU, HxU, sU⟩,
      apply quotient.sound,
      have HUsub : U ⊆ opens.univ ∩ U := λ x HxU, ⟨trivial, HxU⟩,
      use [U, BU, HxU, HUsub, set.subset.refl U],
      repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
      repeat { rw ←presheaf_on_basis.Hcomp' },
      erw (is_ring_hom.map_one ((F.to_presheaf_on_basis).res _ _ _));
      try { apply_instance },
      rw one_mul,
      refl,
    end,
  mul_one :=
    begin
      intros a,
      refine quotient.induction_on a _,
      rintros ⟨U, BU, HxU, sU⟩,
      apply quotient.sound,
      have HUsub : U ⊆ U ∩ opens.univ := λ x HxU, ⟨HxU, trivial⟩,
      use [U, BU, HxU, HUsub, set.subset.refl U],
      repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
      repeat { rw ←presheaf_on_basis.Hcomp' },
      dsimp,
      erw (is_ring_hom.map_one ((F.to_presheaf_on_basis).res _ _ _));
      try { apply_instance },
      rw mul_one,
      refl,
    end,
  ..stalk_of_rings_on_standard_basis.has_one Bstd F x,
  ..stalk_of_rings_on_standard_basis.mul_comm_semigroup Bstd F x }

-- Stalks of rings on standard basis are rings.

instance comm_ring : comm_ring (stalk_of_rings_on_standard_basis Bstd F x) :=
{ left_distrib :=
    begin
      intros a b c,
      refine quotient.induction_on₃ a b c _,
      rintros ⟨U, BU, HxU, sU⟩ ⟨V, BV, HxV, sV⟩ ⟨W, BW, HxW, sW⟩,
      have BUVW := Bstd.2 (Bstd.2 BU BV) BW,
      have HUVWsub : U ∩ V ∩ W ⊆ U ∩ (V ∩ W)
      := λ x ⟨⟨HxU, HxV⟩, HxW⟩, ⟨HxU, ⟨HxV, HxW⟩⟩,
      have HUVWsub2 : U ∩ V ∩ W ⊆ U ∩ V ∩ (U ∩ W)
      := λ x ⟨⟨HxU, HxV⟩, HxW⟩, ⟨⟨HxU, HxV⟩, ⟨HxU, HxW⟩⟩,
      apply quotient.sound,
      use [U ∩ V ∩ W, BUVW, ⟨⟨HxU, HxV⟩, HxW⟩, HUVWsub, HUVWsub2],
      repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
      repeat { rw (F.res_is_ring_hom _ _ _).map_add },
      repeat { rw ←presheaf_on_basis.Hcomp' },
      repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
      repeat { rw (F.res_is_ring_hom _ _ _).map_add },
      repeat { rw ←presheaf_on_basis.Hcomp' },
      rw mul_add,
    end,
  right_distrib :=
    begin
      intros a b c,
      refine quotient.induction_on₃ a b c _,
      rintros ⟨U, BU, HxU, sU⟩ ⟨V, BV, HxV, sV⟩ ⟨W, BW, HxW, sW⟩,
      have BUVW := Bstd.2 (Bstd.2 BU BV) BW,
      have HUVWrfl : U ∩ V ∩ W ⊆ U ∩ V ∩ W := λ x Hx, Hx,
      have HUVWsub : U ∩ V ∩ W ⊆ U ∩ W ∩ (V ∩ W)
      := λ x ⟨⟨HxU, HxV⟩, HxW⟩, ⟨⟨HxU, HxW⟩, ⟨HxV, HxW⟩⟩,
      apply quotient.sound,
      use [U ∩ V ∩ W, BUVW, ⟨⟨HxU, HxV⟩, HxW⟩, HUVWrfl, HUVWsub],
      repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
      repeat { rw (F.res_is_ring_hom _ _ _).map_add },
      repeat { rw ←presheaf_on_basis.Hcomp' },
      repeat { rw (F.res_is_ring_hom _ _ _).map_mul },
      repeat { rw (F.res_is_ring_hom _ _ _).map_add },
      repeat { rw ←presheaf_on_basis.Hcomp' },
      rw add_mul,
    end,
  ..stalk_of_rings_on_standard_basis.add_comm_group Bstd F x,
  ..stalk_of_rings_on_standard_basis.mul_comm_monoid Bstd F x
}

end stalk_of_rings_on_standard_basis_is_ring

end stalk_of_rings_on_standard_basis


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.direct_sum
import algebra.algebra.basic
import algebra.algebra.operations
import group_theory.subgroup

/-!
# Additively-graded multiplicative structures on `⨁ i, A i`

This module provides a set of heterogeneous typeclasses for defining a multiplicative structure
over `⨁ i, A i` such that `(*) : A i → A j → A (i + j)`; that is to say, `A` forms an
additively-graded ring. The typeclasses are:

* `direct_sum.ghas_one A`
* `direct_sum.ghas_mul A`
* `direct_sum.gmonoid A`
* `direct_sum.gcomm_monoid A`

Respectively, these imbue the direct sum `⨁ i, A i` with:

* `direct_sum.has_one`
* `direct_sum.mul_zero_class`, `direct_sum.distrib`
* `direct_sum.semiring`, `direct_sum.ring`
* `direct_sum.comm_semiring`, `direct_sum.comm_ring`

the base ring `A 0` with:

* `direct_sum.grade_zero.has_one`
* `direct_sum.grade_zero.mul_zero_class`, `direct_sum.grade_zero.distrib`
* `direct_sum.grade_zero.semiring`, `direct_sum.grade_zero.ring`
* `direct_sum.grade_zero.comm_semiring`, `direct_sum.grade_zero.comm_ring`

and the `i`th grade `A i` with `A 0`-actions (`•`) defined as left-multiplication:

* (nothing)
* `direct_sum.grade_zero.has_scalar (A 0)`, `direct_sum.grade_zero.smul_with_zero (A 0)`
* `direct_sum.grade_zero.module (A 0)`
* (nothing)

Note that in the presence of these instances, `⨁ i, A i` itself inherits an `A 0`-action.

`direct_sum.of_zero_ring_hom : A 0 →+* ⨁ i, A i` provides `direct_sum.of A 0` as a ring
homomorphism.

## Direct sums of subobjects

Additionally, this module provides helper functions to construct `gmonoid` and `gcomm_monoid`
instances for:

* `A : ι → submonoid S`:
  `direct_sum.ghas_one.of_add_submonoids`, `direct_sum.ghas_mul.of_add_submonoids`,
  `direct_sum.gmonoid.of_add_submonoids`, `direct_sum.gcomm_monoid.of_add_submonoids`.
* `A : ι → subgroup S`:
  `direct_sum.ghas_one.of_add_subgroups`, `direct_sum.ghas_mul.of_add_subgroups`,
  `direct_sum.gmonoid.of_add_subgroups`, `direct_sum.gcomm_monoid.of_add_subgroups`.
* `A : ι → submodule S`:
  `direct_sum.ghas_one.of_submodules`, `direct_sum.ghas_mul.of_submodules`,
  `direct_sum.gmonoid.of_submodules`, `direct_sum.gcomm_monoid.of_submodules`.

If `complete_lattice.independent (set.range A)`, these provide a gradation of `⨆ i, A i`, and the
mapping `⨁ i, A i →+ ⨆ i, A i` can be obtained as
`direct_sum.to_monoid (λ i, add_submonoid.inclusion $ le_supr A i)`.

## tags

graded ring, filtered ring, direct sum, add_submonoid
-/
variables {ι : Type*} [decidable_eq ι]

namespace direct_sum

open_locale direct_sum

/-! ### Typeclasses -/
section defs

variables (A : ι → Type*)

/-- A graded version of `has_one`, which must be of grade 0. -/
class ghas_one [has_zero ι] :=
(one : A 0)

/-- A graded version of `has_mul` that also subsumes `distrib` and `mul_zero_class` by requiring
the multiplication be an `add_monoid_hom`. Multiplication combines grades additively, like
`add_monoid_algebra`. -/
class ghas_mul [has_add ι] [Π i, add_comm_monoid (A i)] :=
(mul {i j} : A i →+ A j →+ A (i + j))

variables {A}

/-- `direct_sum.ghas_one` implies a `has_one (Σ i, A i)`, although this is only used as an instance
locally to define notation in `direct_sum.gmonoid`. -/
def ghas_one.to_sigma_has_one [has_zero ι] [ghas_one A] : has_one (Σ i, A i) := ⟨⟨_, ghas_one.one⟩⟩

/-- `direct_sum.ghas_mul` implies a `has_mul (Σ i, A i)`, although this is only used as an instance
locally to define notation in `direct_sum.gmonoid`. -/
def ghas_mul.to_sigma_has_mul [has_add ι] [Π i, add_comm_monoid (A i)] [ghas_mul A] :
  has_mul (Σ i, A i) :=
⟨λ (x y : Σ i, A i), ⟨_, ghas_mul.mul x.snd y.snd⟩⟩

end defs

section defs

variables (A : ι → Type*)

local attribute [instance] ghas_one.to_sigma_has_one
local attribute [instance] ghas_mul.to_sigma_has_mul

/-- A graded version of `monoid`. -/
class gmonoid [add_monoid ι] [Π i, add_comm_monoid (A i)] extends ghas_mul A, ghas_one A :=
(one_mul (a : Σ i, A i) : 1 * a = a)
(mul_one (a : Σ i, A i) : a * 1 = a)
(mul_assoc (a : Σ i, A i) (b : Σ i, A i) (c : Σ i, A i) : a * b * c = a * (b * c))

/-- A graded version of `comm_monoid`. -/
class gcomm_monoid [add_comm_monoid ι] [Π i, add_comm_monoid (A i)] extends gmonoid A :=
(mul_comm (a : Σ i, A i) (b : Σ i, A i) : a * b = b * a)

end defs

/-! ### Shorthands for creating the above typeclasses -/

section shorthands

variables {R : Type*}

/-! #### From `add_submonoid`s -/

/-- Build a `ghas_one` instance for a collection of `add_submonoid`s. -/
@[simps one]
def ghas_one.of_add_submonoids [semiring R] [has_zero ι]
  (carriers : ι → add_submonoid R)
  (one_mem : (1 : R) ∈ carriers 0) :
  ghas_one (λ i, carriers i) :=
{ one := ⟨1, one_mem⟩ }

-- `@[simps]` doesn't generate a useful lemma, so we state one manually below.
/-- Build a `ghas_mul` instance for a collection of `add_submonoids`. -/
def ghas_mul.of_add_submonoids [semiring R] [has_add ι]
  (carriers : ι → add_submonoid R)
  (mul_mem : ∀ ⦃i j⦄ (gi : carriers i) (gj : carriers j), (gi * gj : R) ∈ carriers (i + j)) :
  ghas_mul (λ i, carriers i) :=
{ mul := λ i j,
  { to_fun := λ a,
    { to_fun := λ b, ⟨(a * b : R), mul_mem a b⟩,
      map_add' := λ _ _, subtype.ext (mul_add _ _ _),
      map_zero' := subtype.ext (mul_zero _), },
    map_add' := λ _ _, add_monoid_hom.ext $ λ _, subtype.ext (add_mul _ _ _),
    map_zero' := add_monoid_hom.ext $ λ _, subtype.ext (zero_mul _) }, }

-- `@[simps]` doesn't generate this well
@[simp] lemma ghas_mul.of_add_submonoids_mul [semiring R] [has_add ι]
  (carriers : ι → add_submonoid R) (mul_mem) {i j} (a : carriers i) (b : carriers j) :
  @ghas_mul.mul _ _ _ _ _ (ghas_mul.of_add_submonoids carriers mul_mem) i j a b =
    ⟨a * b, mul_mem a b⟩ := rfl

/-- Build a `gmonoid` instance for a collection of `add_submonoid`s. -/
@[simps to_ghas_one to_ghas_mul]
def gmonoid.of_add_submonoids [semiring R] [add_monoid ι]
  (carriers : ι → add_submonoid R)
  (one_mem : (1 : R) ∈ carriers 0)
  (mul_mem : ∀ ⦃i j⦄ (gi : carriers i) (gj : carriers j), (gi * gj : R) ∈ carriers (i + j)) :
  gmonoid (λ i, carriers i) :=
{ one_mul := λ ⟨i, a, h⟩, sigma.subtype_ext (zero_add _) (one_mul _),
  mul_one := λ ⟨i, a, h⟩, sigma.subtype_ext (add_zero _) (mul_one _),
  mul_assoc := λ ⟨i, a, ha⟩ ⟨j, b, hb⟩ ⟨k, c, hc⟩,
    sigma.subtype_ext (add_assoc _ _ _) (mul_assoc _ _ _),
  ..ghas_one.of_add_submonoids carriers one_mem,
  ..ghas_mul.of_add_submonoids carriers mul_mem }

/-- Build a `gcomm_monoid` instance for a collection of `add_submonoid`s. -/
@[simps to_gmonoid]
def gcomm_monoid.of_add_submonoids [comm_semiring R] [add_comm_monoid ι]
  (carriers : ι → add_submonoid R)
  (one_mem : (1 : R) ∈ carriers 0)
  (mul_mem : ∀ ⦃i j⦄ (gi : carriers i) (gj : carriers j), (gi * gj : R) ∈ carriers (i + j)) :
  gcomm_monoid (λ i, carriers i) :=
{ mul_comm := λ ⟨i, a, ha⟩ ⟨j, b, hb⟩, sigma.subtype_ext (add_comm _ _) (mul_comm _ _),
  ..gmonoid.of_add_submonoids carriers one_mem mul_mem}

/-! #### From `add_subgroup`s -/

/-- Build a `ghas_one` instance for a collection of `add_subgroup`s. -/
@[simps one]
def ghas_one.of_add_subgroups [ring R] [has_zero ι]
  (carriers : ι → add_subgroup R)
  (one_mem : (1 : R) ∈ carriers 0) :
  ghas_one (λ i, carriers i) :=
ghas_one.of_add_submonoids (λ i, (carriers i).to_add_submonoid) one_mem

-- `@[simps]` doesn't generate a useful lemma, so we state one manually below.
/-- Build a `ghas_mul` instance for a collection of `add_subgroup`s. -/
def ghas_mul.of_add_subgroups [ring R] [has_add ι]
  (carriers : ι → add_subgroup R)
  (mul_mem : ∀ ⦃i j⦄ (gi : carriers i) (gj : carriers j), (gi * gj : R) ∈ carriers (i + j)) :
  ghas_mul (λ i, carriers i) :=
ghas_mul.of_add_submonoids (λ i, (carriers i).to_add_submonoid) mul_mem

-- `@[simps]` doesn't generate this well
@[simp] lemma ghas_mul.of_add_subgroups_mul [ring R] [has_add ι]
  (carriers : ι → add_subgroup R) (mul_mem) {i j} (a : carriers i) (b : carriers j) :
  @ghas_mul.mul _ _ _ _ _ (ghas_mul.of_add_subgroups carriers mul_mem) i j a b =
    ⟨a * b, mul_mem a b⟩ := rfl

/-- Build a `gmonoid` instance for a collection of `add_subgroup`s. -/
@[simps to_ghas_one to_ghas_mul]
def gmonoid.of_add_subgroups [ring R] [add_monoid ι]
  (carriers : ι → add_subgroup R)
  (one_mem : (1 : R) ∈ carriers 0)
  (mul_mem : ∀ ⦃i j⦄ (gi : carriers i) (gj : carriers j), (gi * gj : R) ∈ carriers (i + j)) :
  gmonoid (λ i, carriers i) :=
gmonoid.of_add_submonoids (λ i, (carriers i).to_add_submonoid) one_mem mul_mem

/-- Build a `gcomm_monoid` instance for a collection of `add_subgroup`s. -/
@[simps to_gmonoid]
def gcomm_monoid.of_add_subgroups [comm_ring R] [add_comm_monoid ι]
  (carriers : ι → add_subgroup R)
  (one_mem : (1 : R) ∈ carriers 0)
  (mul_mem : ∀ ⦃i j⦄ (gi : carriers i) (gj : carriers j), (gi * gj : R) ∈ carriers (i + j)) :
  gcomm_monoid (λ i, carriers i) :=
gcomm_monoid.of_add_submonoids (λ i, (carriers i).to_add_submonoid) one_mem mul_mem

/-! #### From `submodules`s -/

variables {A : Type*}

/-- Build a `ghas_one` instance for a collection of `submodule`s. -/
@[simps one]
def ghas_one.of_submodules
  [comm_semiring R] [semiring A] [algebra R A] [has_zero ι]
  (carriers : ι → submodule R A)
  (one_mem : (1 : A) ∈ carriers 0) :
  ghas_one (λ i, carriers i) :=
ghas_one.of_add_submonoids (λ i, (carriers i).to_add_submonoid) one_mem

-- `@[simps]` doesn't generate a useful lemma, so we state one manually below.
/-- Build a `ghas_mul` instance for a collection of `submodule`s. -/
def ghas_mul.of_submodules
  [comm_semiring R] [semiring A] [algebra R A] [has_add ι]
  (carriers : ι → submodule R A)
  (mul_mem : ∀ ⦃i j⦄ (gi : carriers i) (gj : carriers j), (gi * gj : A) ∈ carriers (i + j)) :
  ghas_mul (λ i, carriers i) :=
ghas_mul.of_add_submonoids (λ i, (carriers i).to_add_submonoid) mul_mem

-- `@[simps]` doesn't generate this well
@[simp] lemma ghas_mul.of_submodules_mul
  [comm_semiring R] [semiring A] [algebra R A] [has_add ι]
  (carriers : ι → submodule R A) (mul_mem) {i j} (a : carriers i) (b : carriers j) :
  @ghas_mul.mul _ _ _ _ _ (ghas_mul.of_submodules carriers mul_mem) i j a b =
    ⟨a * b, mul_mem a b⟩ := rfl

/-- Build a `gmonoid` instance for a collection of `submodules`s. -/
@[simps to_ghas_one to_ghas_mul]
def gmonoid.of_submodules
  [comm_semiring R] [semiring A] [algebra R A] [add_monoid ι]
  (carriers : ι → submodule R A)
  (one_mem : (1 : A) ∈ carriers 0)
  (mul_mem : ∀ ⦃i j⦄ (gi : carriers i) (gj : carriers j), (gi * gj : A) ∈ carriers (i + j)) :
  gmonoid (λ i, carriers i) :=
gmonoid.of_add_submonoids (λ i, (carriers i).to_add_submonoid) one_mem mul_mem

/-- Build a `gcomm_monoid` instance for a collection of `submodules`s. -/
@[simps to_gmonoid]
def gcomm_monoid.of_submodules
  [comm_semiring R] [comm_semiring A] [algebra R A] [add_comm_monoid ι]
  (carriers : ι → submodule R A)
  (one_mem : (1 : A) ∈ carriers 0)
  (mul_mem : ∀ ⦃i j⦄ (gi : carriers i) (gj : carriers j), (gi * gj : A) ∈ carriers (i + j)) :
  gcomm_monoid (λ i, carriers i) :=
gcomm_monoid.of_add_submonoids (λ i, (carriers i).to_add_submonoid) one_mem mul_mem

end shorthands

variables (A : ι → Type*)

/-! ### Instances for `⨁ i, A i` -/

section one
variables [has_zero ι] [ghas_one A] [Π i, add_comm_monoid (A i)]

instance : has_one (⨁ i, A i) :=
{ one := direct_sum.of (λ i, A i) 0 ghas_one.one}

end one

section mul
variables [has_add ι] [Π i, add_comm_monoid (A i)] [ghas_mul A]

open add_monoid_hom (map_zero map_add flip_apply coe_comp comp_hom_apply_apply)

/-- The multiplication from the `has_mul` instance, as a bundled homomorphism. -/
def mul_hom : (⨁ i, A i) →+ (⨁ i, A i) →+ ⨁ i, A i :=
direct_sum.to_add_monoid $ λ i,
  add_monoid_hom.flip $ direct_sum.to_add_monoid $ λ j, add_monoid_hom.flip $
    (direct_sum.of A _).comp_hom.comp ghas_mul.mul

instance : has_mul (⨁ i, A i) :=
{ mul := λ a b, mul_hom A a b }

instance : mul_zero_class (⨁ i, A i) :=
{ mul := (*),
  zero := 0,
  zero_mul := λ a, by { unfold has_mul.mul, simp only [map_zero, add_monoid_hom.zero_apply]},
  mul_zero := λ a, by { unfold has_mul.mul, simp only [map_zero] } }

instance : distrib (⨁ i, A i) :=
{ mul := (*),
  add := (+),
  left_distrib := λ a b c, by { unfold has_mul.mul, simp only [map_add]},
  right_distrib := λ a b c, by { unfold has_mul.mul, simp only [map_add, add_monoid_hom.add_apply]}}

variables {A}

lemma mul_hom_of_of {i j} (a : A i) (b : A j) :
  mul_hom A (of _ i a) (of _ j b) = of _ (i + j) (ghas_mul.mul a b) :=
begin
  unfold mul_hom,
  rw [to_add_monoid_of, flip_apply, to_add_monoid_of, flip_apply, coe_comp, function.comp_app,
      comp_hom_apply_apply, coe_comp, function.comp_app],
end

lemma of_mul_of {i j} (a : A i) (b : A j) :
  of _ i a * of _ j b = of _ (i + j) (ghas_mul.mul a b) :=
mul_hom_of_of a b

end mul

section semiring
variables [Π i, add_comm_monoid (A i)] [add_monoid ι] [gmonoid A]

open add_monoid_hom (flip_hom coe_comp comp_hom_apply_apply flip_apply flip_hom_apply)

private lemma one_mul (x : ⨁ i, A i) : 1 * x = x :=
suffices mul_hom A 1 = add_monoid_hom.id (⨁ i, A i),
  from add_monoid_hom.congr_fun this x,
begin
  apply add_hom_ext, intros i xi,
  unfold has_one.one,
  rw mul_hom_of_of,
  exact dfinsupp.single_eq_of_sigma_eq (gmonoid.one_mul ⟨i, xi⟩),
end

private lemma mul_one (x : ⨁ i, A i) : x * 1 = x :=
suffices (mul_hom A).flip 1 = add_monoid_hom.id (⨁ i, A i),
  from add_monoid_hom.congr_fun this x,
begin
  apply add_hom_ext, intros i xi,
  unfold has_one.one,
  rw [flip_apply, mul_hom_of_of],
  exact dfinsupp.single_eq_of_sigma_eq (gmonoid.mul_one ⟨i, xi⟩),
end

private lemma mul_assoc (a b c : ⨁ i, A i) : a * b * c = a * (b * c) :=
suffices (mul_hom A).comp_hom.comp (mul_hom A)            -- `λ a b c, a * b * c` as a bundled hom
       = (add_monoid_hom.comp_hom flip_hom $              -- `λ a b c, a * (b * c)` as a bundled hom
             (mul_hom A).flip.comp_hom.comp (mul_hom A)).flip,
  from add_monoid_hom.congr_fun (add_monoid_hom.congr_fun (add_monoid_hom.congr_fun this a) b) c,
begin
  ext ai ax bi bx ci cx : 6,
  dsimp only [coe_comp, function.comp_app, comp_hom_apply_apply, flip_apply, flip_hom_apply],
  rw [mul_hom_of_of, mul_hom_of_of, mul_hom_of_of, mul_hom_of_of],
  exact dfinsupp.single_eq_of_sigma_eq (gmonoid.mul_assoc ⟨ai, ax⟩ ⟨bi, bx⟩ ⟨ci, cx⟩),
end

/-- The `semiring` structure derived from `gmonoid A`. -/
instance semiring : semiring (⨁ i, A i) := {
  one := 1,
  mul := (*),
  zero := 0,
  add := (+),
  one_mul := one_mul A,
  mul_one := mul_one A,
  mul_assoc := mul_assoc A,
  ..direct_sum.mul_zero_class A,
  ..direct_sum.distrib A,
  ..direct_sum.add_comm_monoid _ _, }

end semiring

section comm_semiring

variables [Π i, add_comm_monoid (A i)] [add_comm_monoid ι] [gcomm_monoid A]

private lemma mul_comm (a b : ⨁ i, A i) : a * b = b * a :=
suffices mul_hom A = (mul_hom A).flip,
  from add_monoid_hom.congr_fun (add_monoid_hom.congr_fun this a) b,
begin
  apply add_hom_ext, intros ai ax, apply add_hom_ext, intros bi bx,
  rw [add_monoid_hom.flip_apply, mul_hom_of_of, mul_hom_of_of],
  exact dfinsupp.single_eq_of_sigma_eq (gcomm_monoid.mul_comm ⟨ai, ax⟩ ⟨bi, bx⟩),
end

/-- The `comm_semiring` structure derived from `gcomm_monoid A`. -/
instance comm_semiring : comm_semiring (⨁ i, A i) := {
  one := 1,
  mul := (*),
  zero := 0,
  add := (+),
  mul_comm := mul_comm A,
  ..direct_sum.semiring _, }

end comm_semiring

section ring
variables [Π i, add_comm_group (A i)] [add_comm_monoid ι] [gmonoid A]

/-- The `ring` derived from `gmonoid A`. -/
instance ring : ring (⨁ i, A i) := {
  one := 1,
  mul := (*),
  zero := 0,
  add := (+),
  neg := has_neg.neg,
  ..(direct_sum.semiring _),
  ..(direct_sum.add_comm_group _), }

end ring

section comm_ring
variables [Π i, add_comm_group (A i)] [add_comm_monoid ι] [gcomm_monoid A]

/-- The `comm_ring` derived from `gcomm_monoid A`. -/
instance comm_ring : comm_ring (⨁ i, A i) := {
  one := 1,
  mul := (*),
  zero := 0,
  add := (+),
  neg := has_neg.neg,
  ..(direct_sum.ring _),
  ..(direct_sum.comm_semiring _), }

end comm_ring

/-! ### Instances for `A 0`

The various `g*` instances are enough to promote the `add_comm_monoid (A 0)` structure to various
types of multiplicative structure.
-/

section grade_zero

section one
variables [has_zero ι] [ghas_one A] [Π i, add_comm_monoid (A i)]

/-- `1 : A 0` is the value provided in `direct_sum.ghas_one.one`. -/
@[nolint unused_arguments]
instance grade_zero.has_one : has_one (A 0) :=
⟨ghas_one.one⟩

@[simp] lemma of_zero_one : of _ 0 (1 : A 0) = 1 := rfl

end one

section mul
variables [add_monoid ι] [Π i, add_comm_monoid (A i)] [ghas_mul A]

/-- `(•) : A 0 → A i → A i` is the value provided in `direct_sum.ghas_mul.mul`, composed with
an `eq.rec` to turn `A (0 + i)` into `A i`.
-/
instance grade_zero.has_scalar (i : ι) : has_scalar (A 0) (A i) :=
{ smul := λ x y, (zero_add i).rec (ghas_mul.mul x y) }

/-- `(*) : A 0 → A 0 → A 0` is the value provided in `direct_sum.ghas_mul.mul`, composed with
an `eq.rec` to turn `A (0 + 0)` into `A 0`.
-/
instance grade_zero.has_mul : has_mul (A 0) :=
{ mul := (•) }

@[simp]lemma grade_zero.smul_eq_mul (a b : A 0) : a • b = a * b := rfl

@[simp] lemma of_zero_smul {i} (a : A 0) (b : A i) : of _ _ (a • b) = of _ _ a * of _ _ b :=
begin
  rw of_mul_of,
  dsimp [has_mul.mul, direct_sum.of, dfinsupp.single_add_hom_apply],
  congr' 1,
  rw zero_add,
  apply eq_rec_heq,
end

@[simp] lemma of_zero_mul (a b : A 0) : of _ 0 (a * b) = of _ 0 a * of _ 0 b:=
of_zero_smul A a b

instance grade_zero.mul_zero_class : mul_zero_class (A 0) :=
function.injective.mul_zero_class (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_mul A)

instance grade_zero.distrib : distrib (A 0) :=
function.injective.distrib (of A 0) dfinsupp.single_injective
  (of A 0).map_add (of_zero_mul A)

instance grade_zero.smul_with_zero (i : ι) : smul_with_zero (A 0) (A i) :=
begin
  letI := smul_with_zero.comp_hom (⨁ i, A i) (of A 0).to_zero_hom,
  refine dfinsupp.single_injective.smul_with_zero (of A i).to_zero_hom (of_zero_smul A),
end

end mul

section semiring
variables [Π i, add_comm_monoid (A i)] [add_monoid ι] [gmonoid A]

/-- The `semiring` structure derived from `gmonoid A`. -/
instance grade_zero.semiring : semiring (A 0) :=
function.injective.semiring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_one A) (of A 0).map_add (of_zero_mul A)

/-- `of A 0` is a `ring_hom`, using the `direct_sum.grade_zero.semiring` structure. -/
def of_zero_ring_hom : A 0 →+* (⨁ i, A i) :=
{ map_one' := of_zero_one A, map_mul' := of_zero_mul A, ..(of _ 0) }

/-- Each grade `A i` derives a `A 0`-module structure from `gmonoid A`. Note that this results
in an overall `module (A 0) (⨁ i, A i)` structure via `direct_sum.module`.
-/
instance grade_zero.module {i} : module (A 0) (A i) :=
begin
  letI := module.comp_hom (⨁ i, A i) (of_zero_ring_hom A),
  exact dfinsupp.single_injective.module (A 0) (of A i) (λ a, of_zero_smul A a),
end

end semiring

section comm_semiring

variables [Π i, add_comm_monoid (A i)] [add_comm_monoid ι] [gcomm_monoid A]

/-- The `comm_semiring` structure derived from `gcomm_monoid A`. -/
instance grade_zero.comm_semiring : comm_semiring (A 0) :=
function.injective.comm_semiring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_one A) (of A 0).map_add (of_zero_mul A)

end comm_semiring

section ring
variables [Π i, add_comm_group (A i)] [add_comm_monoid ι] [gmonoid A]

/-- The `ring` derived from `gmonoid A`. -/
instance grade_zero.ring : ring (A 0) :=
function.injective.ring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_one A) (of A 0).map_add (of_zero_mul A)
  (of A 0).map_neg (of A 0).map_sub

end ring

section comm_ring
variables [Π i, add_comm_group (A i)] [add_comm_monoid ι] [gcomm_monoid A]

/-- The `comm_ring` derived from `gcomm_monoid A`. -/
instance grade_zero.comm_ring : comm_ring (A 0) :=
function.injective.comm_ring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_one A) (of A 0).map_add (of_zero_mul A)
  (of A 0).map_neg (of A 0).map_sub

end comm_ring

end grade_zero

end direct_sum

/-! ### Concrete instances -/

namespace submodule

variables {R A : Type*} [comm_semiring R]

/-- A direct sum of powers of a submodule of an algebra has a multiplicative structure. -/
instance nat_power_direct_sum_gmonoid [semiring A] [algebra R A] (S : submodule R A) :
  direct_sum.gmonoid (λ i : ℕ, ↥(S ^ i)) :=
direct_sum.gmonoid.of_submodules _
  (by { rw [←one_le, pow_zero], exact le_rfl })
  (λ i j p q, by { rw pow_add, exact submodule.mul_mem_mul p.prop q.prop })

/-- A direct sum of powers of a submodule of a commutative algebra has a commutative multiplicative
structure. -/
instance nat_power_direct_sum_gcomm_monoid [comm_semiring A] [algebra R A] (S : submodule R A) :
  direct_sum.gcomm_monoid (λ i : ℕ, ↥(S ^ i)) :=
direct_sum.gcomm_monoid.of_submodules _
  (by { rw [←one_le, pow_zero], exact le_rfl })
  (λ i j p q, by { rw pow_add, exact submodule.mul_mem_mul p.prop q.prop })

end submodule


import ..geom.geom3d

open_locale affine

section foo

universes u
#check add_maps

abbreviation geom3d_frame :=
    (mk_prod_spc (mk_prod_spc geom1d_std_space geom1d_std_space) geom1d_std_space).frame_type
abbreviation geom3d_space (f : geom3d_frame) := spc real_scalar f
noncomputable def geom3d_std_frame :=
    (mk_prod_spc (mk_prod_spc geom1d_std_space geom1d_std_space) geom1d_std_space).frame
noncomputable def geom3d_std_space : geom3d_space geom3d_std_frame :=
    (mk_prod_spc (mk_prod_spc geom1d_std_space geom1d_std_space) geom1d_std_space)

--@[reducible, elab_with_expected_type]
/-
def geom3d_std_frame : geom3d_frame := (let eqpf :
  (add_maps
    (add_maps
      (λi : fin 1, LENGTH) (λi : fin 1, LENGTH)) (λi : fin 1, LENGTH)) =
        LENGTH :=
    by simp * in
  (eq.rec_on eqpf (mk_prod_spc (mk_prod_spc geom1d_std_space geom1d_std_space) geom1d_std_space).fm) : fm real_scalar 3 LENGTH)
-/

/-
def ppp := mk_prod_spc (mk_prod_spc geom1d_std_space geom1d_std_space) geom1d_std_space

#check (merge_prod_fm (merge_prod_fm geom1d_std_frame geom1d_std_frame) geom1d_std_frame)

example : ppp.fm = geom3d_std_frame :=

#check spc.rec_on

#check @spc.rec_on real_scalar _ _ (λ dim, λ id_vec, λf, λ sp,)

#check eq.rec

#check homogeneous

def geom3d_std_space : geom3d_space (_ : geom3d_frame) :=
    begin
        let v : spc real_scalar (_ : fm real_scalar (1 + 1 + 1) (add_maps (add_maps ↑LENGTH ↑LENGTH) ↑LENGTH)) :=
            mk_prod_spc (mk_prod_spc geom1d_std_space geom1d_std_space) geom1d_std_space,
        let f := v.fm,
        let : v.frame_type = fm real_scalar (1 + 1 + 1) (add_maps (add_maps ↑LENGTH ↑LENGTH) ↑LENGTH) := rfl,
        let : v.frame_type = geom3d_frame := begin
            let eqf : (add_maps
    (add_maps
      (λi : fin 1, LENGTH) (λi : fin 1, LENGTH)) (λi : fin 1, LENGTH)) = (λ i:fin 3, LENGTH) := by simp *,
            simp *,
            refl
        end,
        let h : fm real_scalar (1 + 1 + 1) (add_maps (add_maps ↑LENGTH ↑LENGTH) ↑LENGTH) = geom3d_frame
            := begin simp *,
                refl
            end,
        let fm_ := v.fm,
        simp * at v,
        let fm_g : geom3d_frame := eq.rec fm_ (begin

        end),
        let vg : geom3d_space geom3d_frame := eq.rec v (by cc)
        let : v.fm = geom3d_std_frame := rfl,

        exact v,
    end
-/

structure position3d {f : geom3d_frame} (s : geom3d_space f ) extends point s
@[ext] lemma position3d.ext : ∀  {f : geom3d_frame} {s : geom3d_space f } (x y : position3d s),
    x.to_point = y.to_point → x = y :=
    begin
        intros f s x y e,
        cases x,
        cases y,
        simp *,
        have h₁ : ({to_point := x} : position3d s).to_point = x := rfl,
        simp [h₁] at e,
        exact e
    end

noncomputable def position3d.coords {f : geom3d_frame} {s : geom3d_space f } (t :position3d s) :=
    t.to_point.coords

noncomputable def position3d.x {f : geom3d_frame} {s : geom3d_space f } (t :position3d s) : real_scalar :=
    (t.to_point.coords 0).coord

noncomputable def position3d.y {f : geom3d_frame} {s : geom3d_space f } (t :position3d s) : real_scalar :=
    (t.to_point.coords 1).coord

noncomputable def position3d.z {f : geom3d_frame} {s : geom3d_space f } (t :position3d s) : real_scalar :=
    (t.to_point.coords 2).coord

@[simp]
def mk_position3d' {f : geom3d_frame} (s : geom3d_space f ) (p : point s) : position3d s := position3d.mk p
@[simp]
noncomputable def mk_position3d {f : geom3d_frame} (s : geom3d_space f ) (k₁ k₂ k₃ : real_scalar) : position3d s := position3d.mk (mk_point s ⟨[k₁,k₂,k₃],rfl⟩)

@[simp]
noncomputable def mk_position3d'' {f1 f2 f3 : geom1d_frame } { s1 : geom1d_space f1} {s2 : geom1d_space f2} { s3 : geom1d_space f3}
    (p1 : position1d s1) (p2 : position1d s2) (p3 : position1d s3 )
    : position3d (mk_prod_spc (mk_prod_spc s1 s2) s3) :=
    ⟨mk_point_prod (mk_point_prod p1.to_point p2.to_point) p3.to_point⟩

structure displacement3d {f : geom3d_frame} (s : geom3d_space f ) extends vectr s
@[ext] lemma displacement3d.ext : ∀  {f : geom3d_frame} {s : geom3d_space f } (x y : displacement3d s),
    x.to_vectr = y.to_vectr → x = y :=
    begin
        intros f s x y e,
        cases x,
        cases y,
        simp *,
        have h₁ : ({to_vectr := x} : displacement3d s).to_vectr = x := rfl,
        simp [h₁] at e,
        exact e
    end

def displacement3d.frame {f : geom3d_frame} {s : geom3d_space f } (d :displacement3d s) :=
    f

noncomputable def displacement3d.coords {f : geom3d_frame} {s : geom3d_space f } (d :displacement3d s) :=
    d.to_vectr.coords

@[simp]
def mk_displacement3d' {f : geom3d_frame} (s : geom3d_space f ) (v : vectr s) : displacement3d s := displacement3d.mk v
@[simp]
noncomputable def mk_displacement3d  {f : geom3d_frame} (s : geom3d_space f ) (k₁ k₂ k₃ : real_scalar) : displacement3d s := displacement3d.mk (mk_vectr s ⟨[k₁,k₂,k₃],rfl⟩)

@[simp]
noncomputable def mk_displacement3d'' {f1 f2 f3 : geom1d_frame } { s1 : geom1d_space f1} {s2 : geom1d_space f2} { s3 : geom1d_space f3}
    (p1 : displacement1d s1) (p2 : displacement1d s2) (p3 : displacement1d s3 )
    : displacement3d (mk_prod_spc (mk_prod_spc s1 s2) s3) :=
    ⟨mk_vectr_prod (mk_vectr_prod p1.to_vectr p2.to_vectr) p3.to_vectr⟩

@[simp]
noncomputable def mk_geom3d_frame {parent : geom3d_frame} {s : spc real_scalar parent} (p : position3d s)
    (v0 : displacement3d s) (v1 : displacement3d s) (v2 : displacement3d s)
    : geom3d_frame :=
    (mk_frame p.to_point ⟨(λi, if i = 0 then v0.to_vectr else if i = 1 then v1.to_vectr else v2.to_vectr),sorry,sorry⟩)

@[simp]
noncomputable def mk_geom3d_space (fr : geom3d_frame) := mk_space fr

end foo

section bar

/-
    *************************************
    Instantiate module real_scalar (vector real_scalar)
    *************************************
-/

namespace geom3d
variables {f : geom3d_frame} {s : geom3d_space f }
@[simp]
noncomputable def add_displacement3d_displacement3d (v3 v2 : displacement3d s) : displacement3d s :=
    mk_displacement3d' s (v3.to_vectr + v2.to_vectr)
@[simp]
noncomputable def smul_displacement3d (k : real_scalar) (v : displacement3d s) : displacement3d s :=
    mk_displacement3d' s (k • v.to_vectr)
@[simp]
noncomputable def neg_displacement3d (v : displacement3d s) : displacement3d s :=
    mk_displacement3d' s ((-1 : real_scalar) • v.to_vectr)
@[simp]
noncomputable def sub_displacement3d_displacement3d (v3 v2 : displacement3d s) : displacement3d s :=    -- v3-v2
    add_displacement3d_displacement3d v3 (neg_displacement3d v2)

noncomputable instance has_add_displacement3d : has_add (displacement3d s) := ⟨ add_displacement3d_displacement3d ⟩
lemma add_assoc_displacement3d : ∀ a b c : displacement3d s, a + b + c = a + (b + c) := begin
    intros,
    ext,
    dsimp only [has_add.add],
    dsimp only [add_displacement3d_displacement3d, has_add.add],
    dsimp only [add_vectr_vectr, has_add.add],
    dsimp only [add_vec_vec, mk_displacement3d', mk_vectr'],
    simp only [add_assoc],
end
noncomputable instance add_semigroup_displacement3d : add_semigroup (displacement3d s) := ⟨ add_displacement3d_displacement3d, add_assoc_displacement3d⟩
@[simp]
noncomputable def displacement3d_zero  := mk_displacement3d s 0 0 0
noncomputable instance : inhabited (displacement3d s) := ⟨displacement3d_zero⟩
noncomputable instance has_zero_displacement3d : has_zero (displacement3d s) := ⟨displacement3d_zero⟩

lemma zero_add_displacement3d : ∀ a : displacement3d s, 0 + a = a :=
begin
    intros,
    ext,
    dsimp only [has_zero.zero, has_add.add],
    dsimp only [add_displacement3d_displacement3d, displacement3d_zero, mk_displacement3d', mk_displacement3d, has_add.add],
    dsimp only [add_vectr_vectr, mk_vectr', mk_vectr, mk_vec_n, has_add.add],
    dsimp only [add_vec_vec, mk_vec, vector.nth],
    cases x,
    dsimp only [fin.mk],
    cases x_val with x',
    simp only [list.nth_le, zero_add],
    simp only [add_left_eq_self, list.nth_le],
    cases x' with x'',
    simp only [list.nth_le, zero_add],
    simp only [add_left_eq_self, list.nth_le],
    cases x'' with x''',
    simp only [list.nth_le, zero_add],
    have h₀ : x'''.succ.succ.succ = x''' + 3 := rfl,
    have h₁ : 1 + 1 + 1 = 0 + 3 := rfl,
    rw [h₀, h₁] at x_property,
    have h₂ : x'''.succ + 3 ≤ 0 + 3 := begin
        dsimp only [has_lt.lt, nat.lt] at x_property,
        dsimp only [has_le.le],
        exact x_property,
    end,
    have h₃ := (add_le_add_iff_right 3).1 h₂,
    simp only [nat.not_succ_le_zero] at h₃,
    contradiction,
end

lemma add_zero_displacement3d : ∀ a : displacement3d s, a + 0 = a :=
begin
    intros,
    ext,
    dsimp only [has_zero.zero, has_add.add],
    dsimp only [add_displacement3d_displacement3d, displacement3d_zero, mk_displacement3d', mk_displacement3d, has_add.add],
    dsimp only [add_vectr_vectr, mk_vectr', mk_vectr, mk_vec_n, has_add.add],
    dsimp only [add_vec_vec, mk_vec, vector.nth],
    cases x,
    dsimp only [fin.mk],
    cases x_val with x',
    simp only [list.nth_le, add_zero],
    simp only [add_left_eq_self, list.nth_le],
    cases x' with x'',
    simp only [list.nth_le, add_zero],
    simp only [add_left_eq_self, list.nth_le],
    cases x'' with x''',
    simp only [list.nth_le, add_zero],
    have h₀ : x'''.succ.succ.succ = x''' + 3 := rfl,
    have h₁ : 1 + 1 + 1 = 0 + 3 := rfl,
    rw [h₀, h₁] at x_property,
    have h₂ : x'''.succ + 3 ≤ 0 + 3 := begin
        dsimp only [has_lt.lt, nat.lt] at x_property,
        dsimp only [has_le.le],
        exact x_property,
    end,
    have h₃ := (add_le_add_iff_right 3).1 h₂,
    simp only [nat.not_succ_le_zero] at h₃,
    contradiction,
end

@[simp]
noncomputable def nsmul_displacement3d : ℕ → (displacement3d s) → (displacement3d s)
| nat.zero v := displacement3d_zero
--| 3 v := v
| (nat.succ n) v := (add_displacement3d_displacement3d) v (nsmul_displacement3d n v)

noncomputable instance add_monoid_displacement3d : add_monoid (displacement3d s) := ⟨
    -- add_semigroup
    add_displacement3d_displacement3d,
    add_assoc_displacement3d,
    -- has_zero
    displacement3d_zero,
    -- new structure
    @zero_add_displacement3d f s,
    add_zero_displacement3d,
    nsmul_displacement3d,
    begin
        admit
    end,
    begin
        admit
    end
⟩

noncomputable instance has_neg_displacement3d : has_neg (displacement3d s) := ⟨neg_displacement3d⟩
noncomputable instance has_sub_displacement3d : has_sub (displacement3d s) := ⟨ sub_displacement3d_displacement3d⟩
lemma sub_eq_add_neg_displacement3d : ∀ a b : displacement3d s, a - b = a + -b :=
begin
    intros,ext,
    refl,
end

noncomputable instance sub_neg_monoid_displacement3d : sub_neg_monoid (displacement3d s) :=
{
    neg := neg_displacement3d ,
    ..(show add_monoid (displacement3d s), by apply_instance)
}

lemma add_left_neg_displacement3d : ∀ a : displacement3d s, -a + a = 0 :=
begin
    intros,
    ext,
    dsimp only [has_zero.zero, has_add.add, has_neg.neg],
    dsimp only [neg_displacement3d, has_scalar.smul],
    dsimp only [add_displacement3d_displacement3d, smul_vectr, has_add.add, has_scalar.smul],
    dsimp only [add_vectr_vectr, smul_vec, mk_displacement3d', mk_vectr', has_add.add],
    dsimp only [add_vec_vec],
    simp only [neg_mul_eq_neg_mul_symm, one_mul, mk_vectr, displacement3d_zero, mk_displacement3d, add_left_neg],
    dsimp only [mk_vec_n, mk_vec, vector.nth],
    cases x,
    dsimp only [fin.mk],
    cases x_val with x',
    simp only [list.nth_le],
    simp only [add_left_eq_self, list.nth_le],
    cases x' with x'',
    simp only [list.nth_le],
    simp only [add_left_eq_self, list.nth_le],
    cases x'' with x''',
    simp only [list.nth_le],
    have h₀ : x'''.succ.succ.succ = x''' + 3 := rfl,
    have h₁ : 1 + 1 + 1 = 0 + 3 := rfl,
    rw [h₀, h₁] at x_property,
    have h₂ : x'''.succ + 3 ≤ 0 + 3 := begin
        dsimp only [has_lt.lt, nat.lt] at x_property,
        dsimp only [has_le.le],
        exact x_property,
    end,
    have h₃ := (add_le_add_iff_right 3).1 h₂,
    simp only [nat.not_succ_le_zero] at h₃,
    contradiction,
end

noncomputable instance : add_group (displacement3d s) := {
    add_left_neg := begin
        exact add_left_neg_displacement3d,
    end,
..(show sub_neg_monoid (displacement3d s), by apply_instance),

}

lemma add_comm_displacement3d : ∀ a b : displacement3d s, a + b = b + a :=
begin
    intros,
    ext,
    dsimp only [has_add.add],
    dsimp only [add_displacement3d_displacement3d, has_add.add],
    dsimp only [add_vectr_vectr, has_add.add],
    dsimp only [add_vec_vec, mk_displacement3d', mk_vectr'],
    simp only [add_comm],
end
noncomputable instance add_comm_semigroup_displacement3d : add_comm_semigroup (displacement3d s) := ⟨
    -- add_semigroup
    add_displacement3d_displacement3d,
    add_assoc_displacement3d,
    add_comm_displacement3d,
⟩

noncomputable instance add_comm_monoid_displacement3d : add_comm_monoid (displacement3d s) := {
    add_comm := begin
        exact add_comm_displacement3d
    end,
    ..(show add_monoid (displacement3d s), by apply_instance)
}

noncomputable instance has_scalar_displacement3d : has_scalar real_scalar (displacement3d s) := ⟨
smul_displacement3d,
⟩

lemma one_smul_displacement3d : ∀ b : displacement3d s, (1 : real_scalar) • b = b := begin
    intros,
    ext,
    dsimp only [has_scalar.smul],
    dsimp only [smul_displacement3d, has_scalar.smul],
    dsimp only [smul_vectr, has_scalar.smul],
    dsimp only [smul_vec, mk_displacement3d', mk_vectr'],
    simp only [one_mul],
end
lemma mul_smul_displacement3d : ∀ (x y : real_scalar) (b : displacement3d s), (x * y) • b = x • y • b :=
begin
    intros,
    cases b,
    ext,
    exact mul_assoc x y _,
end

noncomputable instance mul_action_displacement3d : mul_action real_scalar (displacement3d s) := ⟨
one_smul_displacement3d,
mul_smul_displacement3d,
⟩

lemma smul_add_displacement3d : ∀(r : real_scalar) (x y : displacement3d s), r • (x + y) = r • x + r • y := begin
    intros,
    ext,
    dsimp only [has_scalar.smul, has_add.add],
    dsimp only [smul_displacement3d, add_displacement3d_displacement3d, has_scalar.smul, has_add.add],
    dsimp only [smul_vectr, add_vectr_vectr, has_scalar.smul, has_add.add],
    dsimp only [smul_vec, add_vec_vec, mk_displacement3d', mk_vectr'],
    simp only [distrib.left_distrib],
    refl,
end
lemma smul_zero_displacement3d : ∀(r : real_scalar), r • (0 : displacement3d s) = 0 := begin
    intros,
    ext,
    dsimp only [has_scalar.smul, has_zero.zero],
    dsimp only [smul_displacement3d, displacement3d_zero, has_scalar.smul],
    dsimp only [smul_vectr, has_scalar.smul],
    dsimp only [smul_vec, mk_displacement3d', mk_vectr', mk_displacement3d, mk_vectr, mk_vec_n, mk_vec, vector.nth],
    cases x,
    dsimp only [fin.mk],
    cases x_val with x',
    simp only [list.nth_le, mul_zero],
    simp only [list.nth_le],
    cases x' with x'',
    simp only [list.nth_le, mul_zero],
    simp only [list.nth_le],
    cases x'' with x''',
    simp only [list.nth_le, mul_zero],
    have h₀ : x'''.succ.succ.succ = x''' + 3 := rfl,
    have h₁ : 1 + 1 + 1 = 0 + 3 := rfl,
    rw [h₀, h₁] at x_property,
    have h₂ : x'''.succ + 3 ≤ 0 + 3 := begin
        dsimp only [has_lt.lt, nat.lt] at x_property,
        dsimp only [has_le.le],
        exact x_property,
    end,
    have h₃ := (add_le_add_iff_right 3).1 h₂,
    simp only [nat.not_succ_le_zero] at h₃,
    contradiction,
end
noncomputable instance distrib_mul_action_K_displacement3d : distrib_mul_action real_scalar (displacement3d s) := ⟨
smul_add_displacement3d,
smul_zero_displacement3d,
⟩

-- renaming vs template due to clash with name "s" for prevailing variable
lemma add_smul_displacement3d : ∀ (a b : real_scalar) (x : displacement3d s), (a + b) • x = a • x + b • x :=
begin
  intros,
  ext,
  exact right_distrib _ _ _,
end
lemma zero_smul_displacement3d : ∀ (x : displacement3d s), (0 : real_scalar) • x = 0 := begin
    intros,
    ext,
    dsimp only [has_scalar.smul, has_zero.zero],
    dsimp only [smul_displacement3d, displacement3d_zero, has_scalar.smul],
    dsimp only [smul_vectr, has_scalar.smul],
    dsimp only [smul_vec, mk_displacement3d', mk_vectr', mk_displacement3d, mk_vectr, mk_vec_n, mk_vec, vector.nth],
    cases x_1,
    dsimp only [fin.mk],
    cases x_1_val with x',
    simp only [list.nth_le, mul_eq_zero],
    apply or.inl,
    refl,
    simp only [list.nth_le],
    cases x' with x'',
    simp only [list.nth_le, mul_eq_zero],
    apply or.inl,
    refl,
    simp only [list.nth_le],
    cases x'' with x''',
    simp only [list.nth_le, mul_eq_zero],
    apply or.inl,
    refl,
    have h₀ : x'''.succ.succ.succ = x''' + 3 := rfl,
    have h₁ : 1 + 1 + 1 = 0 + 3 := rfl,
    rw [h₀, h₁] at x_1_property,
    have h₂ : x'''.succ + 3 ≤ 0 + 3 := begin
        dsimp only [has_lt.lt, nat.lt] at x_1_property,
        dsimp only [has_le.le],
        exact x_1_property,
    end,
    have h₃ := (add_le_add_iff_right 3).1 h₂,
    simp only [nat.not_succ_le_zero] at h₃,
    contradiction,
end
noncomputable instance module_K_displacement3d : module real_scalar (displacement3d s) := ⟨ add_smul_displacement3d, zero_smul_displacement3d ⟩

noncomputable instance add_comm_group_displacement3d : add_comm_group (displacement3d s) := {
    add_comm := begin
        exact add_comm_displacement3d
    end,
..(show add_group (displacement3d s), by apply_instance)
}
noncomputable instance : module real_scalar (displacement3d s) := @geom3d.module_K_displacement3d f s

/-
    ********************
    *** Affine space ***
    ********************
-/

/-
Affine operations
-/
noncomputable instance : has_add (displacement3d s) := ⟨add_displacement3d_displacement3d⟩
noncomputable instance : has_zero (displacement3d s) := ⟨displacement3d_zero⟩
noncomputable instance : has_neg (displacement3d s) := ⟨neg_displacement3d⟩

/-
Lemmas needed to implement affine space API
-/
@[simp]
noncomputable def sub_position3d_position3d {f : geom3d_frame} {s : geom3d_space f } (p3 p2 : position3d s) : displacement3d s :=
    mk_displacement3d' s (p3.to_point -ᵥ p2.to_point)
@[simp]
noncomputable def add_position3d_displacement3d {f : geom3d_frame} {s : geom3d_space f } (p : position3d s) (v : displacement3d s) : position3d s :=
    mk_position3d' s (v.to_vectr +ᵥ p.to_point) -- reorder assumes order is irrelevant
@[simp]
noncomputable def add_displacement3d_position3d {f : geom3d_frame} {s : geom3d_space f } (v : displacement3d s) (p : position3d s) : position3d s :=
    mk_position3d' s (v.to_vectr +ᵥ p.to_point)
--@[simp]
--def aff_displacement3d_group_action : displacement3d s → position3d s → position3d s := add_displacement3d_position3d real_scalar
noncomputable instance : has_vadd (displacement3d s) (position3d s) := ⟨add_displacement3d_position3d⟩

lemma zero_displacement3d_vadd'_a3 : ∀ p : position3d s, (0 : displacement3d s) +ᵥ p = p := begin
    intros,
    ext,
    dsimp only [has_vadd.vadd, has_zero.zero],
    dsimp only [add_displacement3d_position3d, displacement3d_zero, has_vadd.vadd],
    dsimp only [add_vectr_point, has_vadd.vadd],
    dsimp only [aff_vec_group_action, add_vec_pt, mk_position3d', mk_point', mk_displacement3d, mk_vectr, mk_vec_n, mk_vec, vector.nth],
    cases x,
    dsimp only [fin.mk],
    cases x_val with x',
    simp only [list.nth_le, add_zero],
    simp only [list.nth_le],
    cases x' with x'',
    simp only [list.nth_le, add_zero],
    simp only [list.nth_le],
    cases x'' with x''',
    simp only [list.nth_le, add_zero],
    have h₀ : x'''.succ.succ.succ = x''' + 3 := rfl,
    have h₁ : 1 + 1 + 1 = 0 + 3 := rfl,
    rw [h₀, h₁] at x_property,
    have h₂ : x'''.succ + 3 ≤ 0 + 3 := begin
        dsimp only [has_lt.lt, nat.lt] at x_property,
        dsimp only [has_le.le],
        exact x_property,
    end,
    have h₃ := (add_le_add_iff_right 3).1 h₂,
    simp only [nat.not_succ_le_zero] at h₃,
    contradiction,
end
lemma displacement3d_add_assoc'_a3 : ∀ (g3 g2 : displacement3d s) (p : position3d s), g3 +ᵥ (g2 +ᵥ p) = (g3 + g2) +ᵥ p := begin
    intros,
    ext,
    dsimp only [has_add.add, has_vadd.vadd],
    dsimp only [add_displacement3d_position3d, add_displacement3d_displacement3d, has_add.add, has_vadd.vadd],
    dsimp only [add_vectr_point, add_vectr_vectr, has_add.add, has_vadd.vadd],
    dsimp only [aff_vec_group_action, add_vec_vec, add_vec_pt, mk_position3d', mk_point', mk_displacement3d', mk_vectr'],
    simp only [add_assoc, add_right_inj],
    simp only [add_comm],
end

noncomputable instance displacement3d_add_action: add_action (displacement3d s) (position3d s) :=
⟨ zero_displacement3d_vadd'_a3,
begin
    let h0 := displacement3d_add_assoc'_a3,
    intros,
    exact (h0 g₁ g₂ p).symm
end⟩
--@[simp]
--def aff_geom3d_group_sub : position3d s → position3d s → displacement3d s := sub_geom3d_position3d real_scalar
noncomputable instance position3d_has_vsub : has_vsub (displacement3d s) (position3d s) := ⟨ sub_position3d_position3d⟩

instance : nonempty (position3d s) := ⟨mk_position3d s 0 0 0⟩
noncomputable instance : inhabited (position3d s) := ⟨mk_position3d s 0 0 0⟩

lemma position3d_vsub_vadd_a3 : ∀ (p3 p2 : (position3d s)), (p3 -ᵥ p2) +ᵥ p2 = p3 := begin
    intros,
    ext,
    dsimp only [has_vsub.vsub, has_vadd.vadd],
    dsimp only [add_displacement3d_position3d, sub_position3d_position3d, has_vsub.vsub, has_vadd.vadd],
    dsimp only [add_vectr_point, aff_point_group_sub, sub_point_point, has_vsub.vsub, has_vadd.vadd],
    dsimp only [aff_vec_group_action, aff_point_group_sub, add_vec_pt, aff_pt_group_sub, sub_pt_pt, mk_position3d', mk_point', mk_displacement3d', mk_vectr'],
    simp only [add_sub_cancel'_right],
end
lemma position3d_vadd_vsub_a3 : ∀ (g : displacement3d s) (p : position3d s), g +ᵥ p -ᵥ p = g :=
begin
    intros, ext,
    repeat {
    have h0 : ((g +ᵥ p -ᵥ p) : displacement3d s).to_vectr = (g.to_vectr +ᵥ p.to_point -ᵥ p.to_point) := rfl,
    rw h0,
    simp *,
    }

end

noncomputable instance aff_geom3d_torsor : add_torsor (displacement3d s) (position3d s) :=
⟨
    begin
        exact position3d_vsub_vadd_a3,
    end,
    begin
        exact position3d_vadd_vsub_a3,
    end,
⟩

open_locale affine

noncomputable instance : affine_space (displacement3d s) (position3d s) := @geom3d.aff_geom3d_torsor f s

end geom3d -- ha ha
end bar

/-
Newer version
Tradeoff - Does not directly extend from affine equiv. Base class is an equiv on points and vectrs

Extension methods are provided to directly transform Times and Duration between frames
-/
@[ext]
structure geom3d_transform {f3 : geom3d_frame} {f2 : geom3d_frame} (sp3 : geom3d_space f3) (sp2 : geom3d_space f2)
  extends fm_tr sp3 sp2

noncomputable def geom3d_space.mk_geom3d_transform_to {f3 : geom3d_frame} (s3 : geom3d_space f3) : Π {f2 : geom3d_frame} (s2 : geom3d_space f2),
        geom3d_transform s3 s2 := --(position3d s2) ≃ᵃ[scalar] (position3d s3) :=
    λ f2 s2,
        ⟨s3.fm_tr s2⟩

noncomputable instance g3tr_inh {f3 : geom3d_frame} {f2 : geom3d_frame} (sp3 : geom3d_space f3) (sp2 : geom3d_space f2)
    : inhabited (geom3d_transform  sp3 sp2) := ⟨sp3.mk_geom3d_transform_to sp2⟩

noncomputable def geom3d_transform.symm
    {f3 : geom3d_frame} {f2 : geom3d_frame} {sp3 : geom3d_space f3} {sp2 : geom3d_space f2} (ttr : geom3d_transform sp3 sp2)
    : geom3d_transform sp2 sp3 := ⟨(ttr.1).symm⟩

noncomputable def geom3d_transform.trans
    {f3 : geom3d_frame} {f2 : geom3d_frame} {f3 : geom3d_frame} {sp3 : geom3d_space f3} {sp2 : geom3d_space f2} {sp3 : geom3d_space f3}
    (ttr : geom3d_transform sp3 sp2)
    : geom3d_transform sp2 sp3 → geom3d_transform sp3 sp3 := λttr_, ⟨(ttr.1).trans ttr_.1⟩

noncomputable def geom3d_transform.transform_position3d
    {f3 : geom3d_frame} {s3 : geom3d_space f3}
    {f2 : geom3d_frame} {s2 : geom3d_space f2}
    (tr: geom3d_transform s3 s2 ) : position3d s3 → position3d s2 :=
    λt : position3d s3,
    ⟨tr.to_fm_tr.to_equiv t.to_point⟩

noncomputable def geom3d_transform.transform_displacement3d
    {f3 : geom3d_frame} {s3 : geom3d_space f3}
    {f2 : geom3d_frame} {s2 : geom3d_space f2}
    (tr: geom3d_transform s3 s2 ) : displacement3d s3 → displacement3d s2 :=
    λd,
    let as_pt : point s3 := ⟨λi, mk_pt real_scalar (d.coords i).coord⟩ in
    let tr_pt := (tr.to_equiv as_pt) in
    ⟨⟨λi, mk_vec real_scalar (tr_pt.coords i).coord⟩⟩

variables {f : geom3d_frame} (s : geom3d_space f )

structure orientation3d extends orientation s :=
mk ::

noncomputable instance o3i : inhabited (orientation3d s) := ⟨
    ⟨mk_orientation s (λi, mk_vectr s ⟨[0,0,0],rfl⟩)⟩
⟩

noncomputable def mk_orientation3d (s1 s2 s3 s4 s5 s6 s7 s8 s9 : real_scalar)--(ax1 : displacement3d s) (ax2 : displacement3d s) (ax3 : displacement3d s)
    : orientation3d s := ⟨mk_orientation s (λi, if i.1 = 0 then (mk_displacement3d s s1 s2 s3).to_vectr else if i.1 = 1 then (mk_displacement3d s s4 s5 s6).to_vectr else (mk_displacement3d s s7 s8 s9).to_vectr )⟩

    --: orientation3d s := ⟨mk_orientation s (λi, if i.1 = 0 then ax1.to_vectr else if i.1 = 1 then ax2.to_vectr else ax3.to_vectr )⟩

--okay, i can fill in this function now...
noncomputable def mk_orientation3d_from_euler_angles (s1 s2 s3 : real_scalar)--(ax1 : displacement3d s) (ax2 : displacement3d s) (ax3 : displacement3d s)
    : orientation3d s := ⟨mk_orientation s (λi, if i.1 = 0 then (mk_displacement3d s s1 s2 s3).to_vectr else if i.1 = 1 then (mk_displacement3d s s4 s5 s6).to_vectr else (mk_displacement3d s s7 s8 s9).to_vectr )⟩

noncomputable def mk_orientation3d_from_quaternion (s1 s2 s3 s4 : real_scalar)--(ax1 : displacement3d s) (ax2 : displacement3d s) (ax3 : displacement3d s)
    : orientation3d s := mk_orientation3d s
        (2*(s1*s1 + s2*s2) - 1) (2*(s2*s3 - s1*s4)) (2*(s2*s4 + s1*s3))
        (2*(s2*s3 + s1*s4)) (2*(s1*s1 + s3*s3)) (2*(s3*s4 - s1*s2))
        (2*(s2*s4 - s1*s3)) (2*(s3*s4 + s1*s2)) (2*(s1*s1 + s1*s1 + s4*s4) - 1)
    --: orientation3d s := ⟨mk_orientation s (λi, if i.1 = 0 then ax1.to_vectr else if i.1 = 1 then ax2.to_vectr else ax3.to_vectr )⟩

noncomputable def geom3d_transform.transform_orientation
    {f3 : geom3d_frame} {s3 : geom3d_space f3}
    {f2 : geom3d_frame} {s2 : geom3d_space f2}
    (tr: geom3d_transform s3 s2 ) : orientation3d s3 → orientation3d s2 :=
    λo : orientation3d s3,
    ⟨tr.to_fm_tr.transform_orientation o.to_orientation⟩

structure rotation3d extends rotation s :=
mk ::

/-
noncomputable def mk_rotation3d (ax1 : displacement3d s) (ax2 : displacement3d s) (ax3 : displacement3d s)
    : rotation3d s := ⟨mk_rotation s (λi, if i.1 = 0 then ax1.to_vectr else if i.1 = 1 then ax2.to_vectr else ax3.to_vectr )⟩
-/
noncomputable def mk_rotation3d (s1 s2 s3 s4 s5 s6 s7 s8 s9 : real_scalar)--(ax1 : displacement3d s) (ax2 : displacement3d s) (ax3 : displacement3d s)
    : rotation3d s := ⟨mk_rotation s (λi, if i.1 = 0 then (mk_displacement3d s s1 s2 s3).to_vectr else if i.1 = 1 then (mk_displacement3d s s4 s5 s6).to_vectr else (mk_displacement3d s s7 s8 s9).to_vectr )⟩

noncomputable instance r3i : inhabited (rotation3d s) := ⟨
    mk_rotation3d s 1 1 1 1 1 1 1 1 1
⟩

noncomputable def mk_rotation3d_from_quaternion (s1 s2 s3 s4 : real_scalar)--(ax1 : displacement3d s) (ax2 : displacement3d s) (ax3 : displacement3d s)
    : rotation3d s := mk_rotation3d s
        (2*(s1*s1 + s2*s2) - 1) (2*(s2*s3 - s1*s4)) (2*(s2*s4 + s1*s3))
        (2*(s2*s3 + s1*s4)) (2*(s1*s1 + s3*s3)) (2*(s3*s4 - s1*s2))
        (2*(s2*s4 - s1*s3)) (2*(s3*s4 + s1*s2)) (2*(s1*s1 + s1*s1 + s4*s4) - 1)
    --: orientation3d s := ⟨mk_orientation s (λi, if i.1 = 0 then ax1.to_vectr else if i.1 = 1 then ax2.to_vectr else ax3.to_vectr )⟩

structure pose3d :=
mk ::
    (orientation : orientation3d s)
    (position : position3d s)

def mk_pose3d (orientation : orientation3d s)
    (position : position3d s) : pose3d s := ⟨orientation,position⟩

 noncomputable instance p3i : inhabited (pose3d s) := ⟨
    (
    mk_pose3d _
    (mk_orientation3d _ 0 0 0 0 0 0 0 0 0)
    (mk_position3d _ 0 0 0)
    )
⟩

noncomputable def geom3d_transform.transform_pose3d
    {f3 : geom3d_frame} {s3 : geom3d_space f3}
    {f2 : geom3d_frame} {s2 : geom3d_space f2}
    (tr: geom3d_transform s3 s2 ) : pose3d s3 → pose3d s2 :=
    λp :_,
    (⟨tr.transform_orientation p.orientation, tr.transform_position3d p.position⟩:pose3d s2)