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

/-!
# The category of graded objects

For any type `β`, a `β`-graded object over some category `C` is just
a function `β → C` into the objects of `C`.
We put the "pointwise" category structure on these, as the non-dependent specialization of
`category_theory.pi`.

We describe the `comap` functors obtained by precomposing with functions `β → γ`.

As a consequence a fixed element (e.g. `1`) in an additive group `β` provides a shift
functor on `β`-graded objects

When `C` has coproducts we construct the `total` functor `graded_object β C ⥤ C`,
show that it is faithful, and deduce that when `C` is concrete so is `graded_object β C`.
-/

open category_theory.pi
open category_theory.limits

namespace category_theory

universes w v u

/-- A type synonym for `β → C`, used for `β`-graded objects in a category `C`. -/
def graded_object (β : Type w) (C : Type u) : Type (max w u) := β → C

-- Satisfying the inhabited linter...
instance inhabited_graded_object (β : Type w) (C : Type u) [inhabited C] :
  inhabited (graded_object β C) :=
⟨λ b, inhabited.default⟩

/--
A type synonym for `β → C`, used for `β`-graded objects in a category `C`
with a shift functor given by translation by `s`.
-/
@[nolint unused_arguments] -- `s` is here to distinguish type synonyms asking for different shifts
abbreviation graded_object_with_shift {β : Type w} [add_comm_group β] (s : β) (C : Type u) :
  Type (max w u) := graded_object β C

namespace graded_object

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

instance category_of_graded_objects (β : Type w) : category.{(max w v)} (graded_object β C) :=
category_theory.pi (λ _, C)

/-- The projection of a graded object to its `i`-th component. -/
@[simps] def eval {β : Type w} (b : β) : graded_object β C ⥤ C :=
{ obj := λ X, X b,
  map := λ X Y f, f b, }

section
variable (C)

/--
The natural isomorphism comparing between
pulling back along two propositionally equal functions.
-/
@[simps]
def comap_eq {β γ : Type w} {f g : β → γ} (h : f = g) : comap (λ _, C) f ≅ comap (λ _, C) g :=
{ hom := { app := λ X b, eq_to_hom begin dsimp [comap], subst h, end },
  inv := { app := λ X b, eq_to_hom begin dsimp [comap], subst h, end }, }

lemma comap_eq_symm {β γ : Type w} {f g : β → γ} (h : f = g) :
  comap_eq C h.symm = (comap_eq C h).symm :=
by tidy

lemma comap_eq_trans {β γ : Type w} {f g h : β → γ} (k : f = g) (l : g = h) :
  comap_eq C (k.trans l) = comap_eq C k ≪≫ comap_eq C l :=
begin
  ext X b,
  simp,
end

@[simp] lemma eq_to_hom_apply {β : Type w} {X Y : Π b : β, C} (h : X = Y) (b : β) :
  (eq_to_hom h : X ⟶ Y) b = eq_to_hom (by subst h) :=
by { subst h, refl }

/--
The equivalence between β-graded objects and γ-graded objects,
given an equivalence between β and γ.
-/
@[simps]
def comap_equiv {β γ : Type w} (e : β ≃ γ) :
  (graded_object β C) ≌ (graded_object γ C) :=
{ functor := comap (λ _, C) (e.symm : γ → β),
  inverse := comap (λ _, C) (e : β → γ),
  counit_iso := (comap_comp (λ _, C) _ _).trans (comap_eq C (by { ext, simp } )),
  unit_iso := (comap_eq C (by { ext, simp } )).trans (comap_comp _ _ _).symm,
  functor_unit_iso_comp' := λ X, by { ext b, dsimp, simp, }, }  -- See note [dsimp, simp].

end

local attribute [reducible, instance] endofunctor_monoidal_category discrete.add_monoidal

instance has_shift {β : Type*} [add_comm_group β] (s : β) :
  has_shift (graded_object_with_shift s C) ℤ :=
has_shift_mk _ _
{ F := λ n, comap (λ _, C) $ λ (b : β), b + n • s,
  ε := (comap_id β (λ _, C)).symm ≪≫ (comap_eq C (by { ext, simp })),
  μ := λ m n, comap_comp _ _ _ ≪≫ comap_eq C (by { ext, simp [add_zsmul, add_comm] }),
  left_unitality := by { introv, ext, dsimp, simpa },
  right_unitality := by { introv, ext, dsimp, simpa },
  associativity := by { introv, ext, dsimp, simp } }

@[simp] lemma shift_functor_obj_apply {β : Type*} [add_comm_group β]
  (s : β) (X : β → C) (t : β) (n : ℤ) :
  (shift_functor (graded_object_with_shift s C) n).obj X t = X (t + n • s) :=
rfl

@[simp] lemma shift_functor_map_apply {β : Type*} [add_comm_group β] (s : β)
  {X Y : graded_object_with_shift s C} (f : X ⟶ Y) (t : β) (n : ℤ) :
  (shift_functor (graded_object_with_shift s C) n).map f t = f (t + n • s) :=
rfl

instance has_zero_morphisms [has_zero_morphisms C] (β : Type w) :
  has_zero_morphisms.{(max w v)} (graded_object β C) :=
{ has_zero := λ X Y,
  { zero := λ b, 0 } }

@[simp]
lemma zero_apply [has_zero_morphisms C] (β : Type w) (X Y : graded_object β C) (b : β) :
  (0 : X ⟶ Y) b = 0 := rfl

section
open_locale zero_object

instance has_zero_object [has_zero_object C] [has_zero_morphisms C] (β : Type w) :
  has_zero_object.{(max w v)} (graded_object β C) :=
{ zero := λ b, (0 : C),
  unique_to := λ X, ⟨⟨λ b, 0⟩, λ f, (by ext)⟩,
  unique_from := λ X, ⟨⟨λ b, 0⟩, λ f, (by ext)⟩, }
end

end graded_object

namespace graded_object
-- The universes get a little hairy here, so we restrict the universe level for the grading to 0.
-- Since we're typically interested in grading by ℤ or a finite group, this should be okay.
-- If you're grading by things in higher universes, have fun!
variables (β : Type)
variables (C : Type u) [category.{v} C]
variables [has_coproducts C]

/--
The total object of a graded object is the coproduct of the graded components.
-/
noncomputable def total : graded_object β C ⥤ C :=
{ obj := λ X, ∐ (λ i : ulift.{v} β, X i.down),
  map := λ X Y f, limits.sigma.map (λ i, f i.down) }.

variables [has_zero_morphisms C]

/--
The `total` functor taking a graded object to the coproduct of its graded components is faithful.
To prove this, we need to know that the coprojections into the coproduct are monomorphisms,
which follows from the fact we have zero morphisms and decidable equality for the grading.
-/
instance : faithful (total β C) :=
{ map_injective' := λ X Y f g w,
  begin
    classical,
    ext i,
    replace w := sigma.ι (λ i : ulift.{v} β, X i.down) ⟨i⟩ ≫= w,
    erw [colimit.ι_map, colimit.ι_map] at w,
    exact mono.right_cancellation _ _ w,
  end }

end graded_object

namespace graded_object

noncomputable theory

variables (β : Type)
variables (C : Type (u+1)) [large_category C] [concrete_category C]
  [has_coproducts C] [has_zero_morphisms C]

instance : concrete_category (graded_object β C) :=
{ forget := total β C ⋙ forget C }

instance : has_forget₂ (graded_object β C) C :=
{ forget₂ := total β C }

end graded_object

end category_theory


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.erase_dup
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# The fold operation for a commutative associative operation over a multiset.
-/

namespace multiset

/-! ### fold -/

/-- `fold op b s` folds a commutative associative operation `op` over
  the multiset `s`. -/
def fold {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] : α → multiset α → α :=
  foldr op sorry

theorem fold_eq_foldr {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (s : multiset α) : fold op b s = foldr op (left_comm op is_commutative.comm is_associative.assoc) b s :=
  rfl

@[simp] theorem coe_fold_r {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (l : List α) : fold op b ↑l = list.foldr op b l :=
  rfl

theorem coe_fold_l {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (l : List α) : fold op b ↑l = list.foldl op b l := sorry

theorem fold_eq_foldl {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (s : multiset α) : fold op b s = foldl op (right_comm op is_commutative.comm is_associative.assoc) b s :=
  quot.induction_on s fun (l : List α) => coe_fold_l op b l

@[simp] theorem fold_zero {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) : fold op b 0 = b :=
  rfl

@[simp] theorem fold_cons_left {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (a : α) (s : multiset α) : fold op b (a ::ₘ s) = op a (fold op b s) :=
  foldr_cons op (fold._proof_1 op)

theorem fold_cons_right {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (a : α) (s : multiset α) : fold op b (a ::ₘ s) = op (fold op b s) a := sorry

theorem fold_cons'_right {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (a : α) (s : multiset α) : fold op b (a ::ₘ s) = fold op (op b a) s := sorry

theorem fold_cons'_left {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (a : α) (s : multiset α) : fold op b (a ::ₘ s) = fold op (op a b) s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (fold op b (a ::ₘ s) = fold op (op a b) s)) (fold_cons'_right op b a s)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (fold op (op b a) s = fold op (op a b) s)) (is_commutative.comm b a)))
      (Eq.refl (fold op (op a b) s)))

theorem fold_add {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b₁ : α) (b₂ : α) (s₁ : multiset α) (s₂ : multiset α) : fold op (op b₁ b₂) (s₁ + s₂) = op (fold op b₁ s₁) (fold op b₂ s₂) := sorry

theorem fold_singleton {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (a : α) : fold op b (a ::ₘ 0) = op a b := sorry

theorem fold_distrib {α : Type u_1} {β : Type u_2} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] {f : β → α} {g : β → α} (u₁ : α) (u₂ : α) (s : multiset β) : fold op (op u₁ u₂) (map (fun (x : β) => op (f x) (g x)) s) = op (fold op u₁ (map f s)) (fold op u₂ (map g s)) := sorry

theorem fold_hom {α : Type u_1} {β : Type u_2} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] {op' : β → β → β} [is_commutative β op'] [is_associative β op'] {m : α → β} (hm : ∀ (x y : α), m (op x y) = op' (m x) (m y)) (b : α) (s : multiset α) : fold op' (m b) (map m s) = m (fold op b s) := sorry

theorem fold_union_inter {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] [DecidableEq α] (s₁ : multiset α) (s₂ : multiset α) (b₁ : α) (b₂ : α) : op (fold op b₁ (s₁ ∪ s₂)) (fold op b₂ (s₁ ∩ s₂)) = op (fold op b₁ s₁) (fold op b₂ s₂) := sorry

@[simp] theorem fold_erase_dup_idem {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] [DecidableEq α] [hi : is_idempotent α op] (s : multiset α) (b : α) : fold op b (erase_dup s) = fold op b s := sorry

theorem le_smul_erase_dup {α : Type u_1} [DecidableEq α] (s : multiset α) : ∃ (n : ℕ), s ≤ n •ℕ erase_dup s := sorry


import algebra.module.linear_map
import ring_theory.power_series.basic

variables {σ R : Type*}
variables (R) [semiring R]
/-
theorem linear_map_test :
is_linear_map  R (λ (z:R), z) :=
begin
  refine {map_add := _, map_smul := _},
  intros,
  simp,
  intros,
  simp,
end
-/
theorem pow_series_mk_is_lin_map (R :Type) [semiring R]:
is_linear_map R (λ (z:power_series R), z) :=
begin
  refine {map_add := _, map_smul := _},
  repeat {simp only [forall_const, eq_self_iff_true]},
end


import for_mathlib.homological_complex_op
import for_mathlib.homotopy_category

noncomputable theory

open opposite category_theory category_theory.limits

variables {ι : Type*} (c : complex_shape ι)

namespace complex_shape

@[simp]
lemma symm_next (i : ι) : c.symm.next i = c.prev i := rfl

@[simp]
lemma symm_prev (i : ι) : c.symm.prev i = c.next i := rfl

end complex_shape

namespace homological_complex

lemma op_functor_map_homotopy {ι C : Type*} {c : complex_shape ι} [category C] [preadditive C]
  {X Y : homological_complex C c}
  (f₁ f₂ : X ⟶ Y) (H : homotopy f₁ f₂) :
  homotopy
    (homological_complex.op_functor.map f₁.op)
    (homological_complex.op_functor.map f₂.op) :=
{ hom := λ i j, (H.hom j i).op,
  zero' := λ i j hij, by rw [H.zero j i hij, op_zero],
  comm := λ i, begin
    simp only [homological_complex.op_functor_map_f, quiver.hom.unop_op, H.comm i,
      op_add, add_left_inj],
    conv_lhs { rw add_comm, },
    congr' 1,
    { rcases hi : c.prev i with _ | ⟨j, hj⟩,
      { dsimp [prev_d, d_next],
        simpa only [hi], },
      { have hj' : c.symm.rel i j := hj,
        simpa only [prev_d_eq _ hj, d_next_eq _ hj'], }, },
    { rcases hi : c.next i with _ | ⟨j, hj⟩,
      { dsimp [prev_d, d_next],
        simpa only [hi], },
      { have hj' : c.symm.rel j i := hj,
        simpa only [d_next_eq _ hj, prev_d_eq _ hj'], }, },
  end, }

end homological_complex

namespace homotopy_category

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

def op_functor : (homotopy_category C c)ᵒᵖ ⥤ homotopy_category Cᵒᵖ c.symm :=
functor.left_op (category_theory.quotient.lift _
  (homological_complex.op_functor ⋙ homotopy_category.quotient Cᵒᵖ c.symm).right_op
(λ X Y f₁ f₂ h, begin
  dsimp only [functor.right_op],
  congr' 1,
  dsimp only [functor.comp_map],
  erw quotient.functor_map_eq_iff,
  refine ⟨homological_complex.op_functor_map_homotopy f₁ f₂ h.some⟩,
end))

def quotient_op_functor :
  (quotient C c).op ⋙ op_functor ≅ homological_complex.op_functor ⋙ quotient Cᵒᵖ c.symm :=
nat_iso.of_components (λ X, eq_to_iso (by refl))
(λ X Y f, by { dsimp, simpa only [category.comp_id, category.id_comp], })

def unop_functor : (homotopy_category Cᵒᵖ c)ᵒᵖ ⥤ homotopy_category C c.symm :=
functor.left_op (category_theory.quotient.lift _
  (homological_complex.unop_functor ⋙ homotopy_category.quotient C c.symm).right_op
(λ X Y f₁ f₂ h, begin
  dsimp only [functor.right_op],
  congr' 1,
  dsimp only [functor.comp_map],
  erw quotient.functor_map_eq_iff,
  let H := h.some,
  exact nonempty.intro
  { hom := λ i j, (H.hom j i).unop,
    zero' := λ i j hij, by rw [H.zero j i hij, unop_zero],
    comm := λ i, begin
      apply quiver.hom.op_inj,
      simp only [homological_complex.unop_functor_map_f, op_add, quiver.hom.op_unop,
        quiver.hom.unop_op, H.comm i],
      conv_lhs { congr, rw add_comm, },
      congr' 2,
      { rcases hi : c.prev i with _ | ⟨j, hj⟩,
        { dsimp [prev_d, d_next],
          simpa only [hi], },
        { have hj' : c.symm.rel i j := hj,
          simpa only [prev_d_eq _ hj, d_next_eq _ hj'], }, },
      { rcases hi : c.next i with _ | ⟨j, hj⟩,
        { dsimp [prev_d, d_next],
          simpa only [hi], },
        { have hj' : c.symm.rel j i := hj,
          simpa only [d_next_eq _ hj, prev_d_eq _ hj'], }, },
    end, },
end))

def quotient_unop_functor :
  (quotient Cᵒᵖ c).op ⋙ unop_functor ≅ homological_complex.unop_functor ⋙ quotient C c.symm :=
nat_iso.of_components (λ X, eq_to_iso (by refl))
(λ X Y f, by { dsimp, simpa only [category.comp_id, category.id_comp], })

end homotopy_category


import Lib.Tactic

inductive EqvGen (R : α → α → Prop) : α → α → Prop :=
| rfl {x} : EqvGen R x x
| step {x y z} : R x y → EqvGen R y z → EqvGen R x z
| symm_step {x y z} : R y x → EqvGen R y z → EqvGen R x z

namespace EqvGen

variable {R : α → α → Prop}

theorem once (h : R x y) : EqvGen R x y := EqvGen.step h EqvGen.rfl
theorem once_symm (h : R y x) : EqvGen R x y := EqvGen.symm_step h EqvGen.rfl

theorem trans : EqvGen R x y → EqvGen R y z → EqvGen R x z := by
  intros h₀ h₁
  induction h₀ with
  | rfl => exact h₁
  | step hR hGen IH => exact step hR (IH h₁)
  | symm_step hR hGen IH => exact symm_step hR (IH h₁)

theorem symm_step_r : EqvGen R x y → R z y → EqvGen R x z := by
  intros h₀ h₁
  have h₁ := once_symm h₁
  apply trans <;> assumption
theorem step_r : EqvGen R x y → R y z → EqvGen R x z := by
  intros h₀ h₁
  have h₁ := once h₁
  apply trans <;> assumption

theorem symm : EqvGen R x y → EqvGen R y x := by
  intros h
  induction h with
  | rfl => exact rfl
  | step hR hGen IH => exact trans IH (symm_step hR rfl)
  | symm_step hR hGen IH => exact trans IH (step hR rfl)

end EqvGen

namespace Quot
variable {r : α → α → Prop}
variable {r' : α' → α' → Prop}

def map (f : α → α') (hf : ∀ x y, r x y → r' (f x) (f y)) : Quot r → Quot r' :=
Quot.lift (λ a => Quot.mk _ (f a)) $ by
  intros; apply Quot.sound; auto

def toQuotEqvGen : Quot r → Quot (EqvGen r) :=
map id $ λ x y => EqvGen.once

def liftOn₂ (x : Quot r) (y : Quot r') (f : α → α' → β)
  (h : ∀ (a b : α) (a' : α'),
    r a b → f a a' = f b a')
  (h' : ∀ (a : α) (a' b' : α'),
    r' a' b' → f a a' = f a b') : β :=
Quot.liftOn x
  (λ x => Quot.liftOn y (f x) $
    by intros; auto) $
  by intros
     induction y using Quot.inductionOn
     simp [Quot.liftOn]; auto

@[simp]
def liftOn₂_beta {x : α} {y : α'} (f : α → α' → β)
  (h : ∀ (a b : α) (a' : α'),
    r a b → f a a' = f b a')
  (h' : ∀ (a : α) (a' b' : α'),
    r' a' b' → f a a' = f a b') :
liftOn₂ (Quot.mk _ x) (Quot.mk _ y) f h h' = f x y :=
by simp [liftOn₂]

noncomputable def out (x : Quot r) : α :=
Classical.choose (exists_rep x)

theorem eq' : Quot.mk r x = Quot.mk r y ↔ EqvGen r x y := by
  constructor
  focus
    intros h
    have Hlift : ∀ (a b : α), r a b → EqvGen r x a = EqvGen r x b := by
      intros a b Hab
      apply propext
      constructor <;> intro h
      focus apply EqvGen.step_r <;> assumption
      focus apply EqvGen.symm_step_r <;> assumption
    rw [← Quot.liftBeta (r := r) (EqvGen r x) Hlift, ← h,
          Quot.liftBeta (r := r) _ Hlift]
    exact EqvGen.rfl
  focus
    intros h
    induction h with
    | rfl => refl
    | step Hr Hgen IH =>
      rw [← IH]
      apply Quot.sound; assumption
    | symm_step Hr Hgen IH =>
      apply Eq.symm
      rw [← IH]
      apply Quot.sound; assumption

theorem eq : Quot.mk r x = Quot.mk r y ↔ EqvGen r x y := by
  constructor
  focus
    intros h
    rewrite [← liftOn₂_beta (r:=r) (r':=r) (EqvGen r), h, liftOn₂_beta]
    focus
      exact EqvGen.rfl
    focus
      intros x y z Hxy
      apply propext
      constructor <;> intro h
      focus apply EqvGen.symm_step <;> assumption
      focus apply EqvGen.step <;> assumption
    focus
      intros x y z Hxy
      apply propext
      constructor <;> intro h
      focus apply EqvGen.step_r <;> assumption
      focus apply EqvGen.symm_step_r <;> assumption
  focus
    intros h
    induction h with
    | rfl => refl
    | step Hr Hgen IH =>
      rw [← IH]
      apply Quot.sound; assumption
    | symm_step Hr Hgen IH =>
      apply Eq.symm
      rw [← IH]
      apply Quot.sound; assumption

end Quot

attribute [auto] Quot.sound

def Relation1 (F : Type u → Type v) :=
{{α : Type u}} → F α → F α → Prop

class Relation1.Functorial {F} [Functor F] (R : Relation1 F) where
  rel_map {α β} (x y : F α) (f : α → β) : R x y → R (f <$> x) (f <$> y)

attribute [auto] Relation1.Functorial.rel_map

class Relation1.Applicative {F} [H : Applicative F] (R : Relation1 F)
      extends Relation1.Functorial R where
  refl {α} (x : F α) : R x x
  rel_pure {α : Type u} (x : α) : R (pure x) (pure x)
  rel_seq {α β : Type u} (x y : Unit → F α) (f g : F (α → β)) :
    R f g →
    R (x ()) (y ()) →
    R (Seq.seq f x) (Seq.seq g y)
  rel_map {α β : Type u} (x y : F α) (f : α → β) :=
    λ HR : R x y =>
    suffices R (pure f <*> x) (pure f <*> y) by simp [*]
    rel_seq _ _ _ _ (rel_pure _) HR

instance  {F} [Applicative F] (R : Relation1 F) [Relation1.Applicative R] :
          Reflexive (@R α) where
  refl := Relation1.Applicative.refl

attribute [auto] Relation1.Applicative.rel_pure Relation1.Applicative.rel_seq

def Quot1 {F} (R : Relation1 F) (α : Type u) := Quot (@R α)

namespace Quot1

variable {F : Type u → Type v} (R : Relation1 F)
variable {G : Type u → Type v} (R' : Relation1 G)

@[matchPattern]
def mk {α} (x : F α) : Quot1 R α :=
Quot.mk _ x

variable {R} {R'}

@[recursor 3]
def lift {α β} (f : F α → β) (h : ∀ x y : F α, R x y → f x = f y) : Quot1 R α → β :=
Quot.lift f h

section lift₂

def lift₂ {α β γ} (f : F α → G β → γ)
    (hF : ∀ x y : F α, ∀ z, R x y → f x z = f y z)
    (hG : ∀ x y : G β, ∀ z, R' x y → f z x = f z y) :
  Quot1 R α → Quot1 R' β → γ :=
λ x y =>
Quot.liftOn₂ x y f
  (λ x y z => hF _ _ _)
  (λ x y z => hG _ _ _)

def liftOn₂ {α β γ}
    (x : Quot1 R α) (y : Quot1 R' β)
    (f : F α → G β → γ)
    (hF : ∀ x y : F α, ∀ z, R x y → f x z = f y z)
    (hG : ∀ x y : G β, ∀ z, R' x y → f z x = f z y) : γ :=
lift₂ _ hF hG x y

end lift₂

@[simp]
theorem lift_mk  {α β} (f : F α → β) (x : F α) h :
  lift f h (mk R x) = f x :=
Quot.liftBeta _ h x

@[auto]
theorem sound (x y : F α) : R x y → mk R x = mk R y :=
Quot.sound

theorem ind {α} {β : Quot1 R α → Prop} (f : ∀ x, β (mk R x)) : ∀ x, β x :=
Quot.ind f

section Functorial
variable [Functor F]
variable [R.Functorial]

instance : Functor (Quot1 R) where
  map f := Quot1.lift (Quot1.mk _ ∘ (f <$> .)) $ by auto with 6

end Functorial

section Applicative
variable [Applicative F] [LawfulApplicative F]
variable [R.Applicative]

instance : Applicative (Quot1 R) where
  pure x := Quot1.mk _ (pure x)
  seq f x := Quot1.liftOn₂ f (x ())
    (λ f x => Quot1.mk R (f <*> x))
    ( by auto with 7 )
    ( by auto with 7 )

end Applicative

end Quot1