/-
Copyright (c) 2022 Thomas Browning. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning
-/

import group_theory.abelianization
import group_theory.exponent
import group_theory.transfer

/-!
# Schreier's Lemma

In this file we prove Schreier's lemma.

## Main results

- `closure_mul_image_eq` : **Schreier's Lemma**: If `R : set G` is a right_transversal
  of `H : subgroup G` with `1 ∈ R`, and if `G` is generated by `S : set G`,
  then `H` is generated by the `set` `(R * S).image (λ g, g * (to_fun hR g)⁻¹)`.
- `fg_of_index_ne_zero` : **Schreier's Lemma**: A finite index subgroup of a finitely generated
  group is finitely generated.
- `card_commutator_le_of_finite_commutator_set`: A theorem of Schur: The size of the commutator
  subgroup is bounded in terms of the number of commutators.
-/

open_locale pointwise

namespace subgroup

open mem_right_transversals

variables {G : Type*} [group G] {H : subgroup G} {R S : set G}

lemma closure_mul_image_mul_eq_top
  (hR : R ∈ right_transversals (H : set G)) (hR1 : (1 : G) ∈ R) (hS : closure S = ⊤) :
  (closure ((R * S).image (λ g, g * (to_fun hR g)⁻¹)) : set G) * R = ⊤ :=
begin
  let f : G → R := λ g, to_fun hR g,
  let U : set G := (R * S).image (λ g, g * (f g)⁻¹),
  change (closure U : set G) * R = ⊤,
  refine top_le_iff.mp (λ g hg, _),
  apply closure_induction_right (eq_top_iff.mp hS (mem_top g)),
  { exact ⟨1, 1, (closure U).one_mem, hR1, one_mul 1⟩ },
  { rintros - s hs ⟨u, r, hu, hr, rfl⟩,
    rw show u * r * s = u * ((r * s) * (f (r * s))⁻¹) * f (r * s), by group,
    refine set.mul_mem_mul ((closure U).mul_mem hu _) (f (r * s)).coe_prop,
    exact subset_closure ⟨r * s, set.mul_mem_mul hr hs, rfl⟩ },
  { rintros - s hs ⟨u, r, hu, hr, rfl⟩,
    rw show u * r * s⁻¹ = u * (f (r * s⁻¹) * s * r⁻¹)⁻¹ * f (r * s⁻¹), by group,
    refine set.mul_mem_mul ((closure U).mul_mem hu ((closure U).inv_mem _)) (f (r * s⁻¹)).2,
    refine subset_closure ⟨f (r * s⁻¹) * s, set.mul_mem_mul (f (r * s⁻¹)).2 hs, _⟩,
    rw [mul_right_inj, inv_inj, ←subtype.coe_mk r hr, ←subtype.ext_iff, subtype.coe_mk],
    apply (mem_right_transversals_iff_exists_unique_mul_inv_mem.mp hR (f (r * s⁻¹) * s)).unique
      (mul_inv_to_fun_mem hR (f (r * s⁻¹) * s)),
    rw [mul_assoc, ←inv_inv s, ←mul_inv_rev, inv_inv],
    exact to_fun_mul_inv_mem hR (r * s⁻¹) },
end

/-- **Schreier's Lemma**: If `R : set G` is a right_transversal of `H : subgroup G`
  with `1 ∈ R`, and if `G` is generated by `S : set G`, then `H` is generated by the `set`
  `(R * S).image (λ g, g * (to_fun hR g)⁻¹)`. -/
lemma closure_mul_image_eq
  (hR : R ∈ right_transversals (H : set G)) (hR1 : (1 : G) ∈ R) (hS : closure S = ⊤) :
  closure ((R * S).image (λ g, g * (to_fun hR g)⁻¹)) = H :=
begin
  have hU : closure ((R * S).image (λ g, g * (to_fun hR g)⁻¹)) ≤ H,
  { rw closure_le,
    rintros - ⟨g, -, rfl⟩,
    exact mul_inv_to_fun_mem hR g },
  refine le_antisymm hU (λ h hh, _),
  obtain ⟨g, r, hg, hr, rfl⟩ :=
  show h ∈ _, from eq_top_iff.mp (closure_mul_image_mul_eq_top hR hR1 hS) (mem_top h),
  suffices : (⟨r, hr⟩ : R) = (⟨1, hR1⟩ : R),
  { rwa [show r = 1, from subtype.ext_iff.mp this, mul_one] },
  apply (mem_right_transversals_iff_exists_unique_mul_inv_mem.mp hR r).unique,
  { rw [subtype.coe_mk, mul_inv_self],
    exact H.one_mem },
  { rw [subtype.coe_mk, inv_one, mul_one],
    exact (H.mul_mem_cancel_left (hU hg)).mp hh },
end

/-- **Schreier's Lemma**: If `R : set G` is a right_transversal of `H : subgroup G`
  with `1 ∈ R`, and if `G` is generated by `S : set G`, then `H` is generated by the `set`
  `(R * S).image (λ g, g * (to_fun hR g)⁻¹)`. -/
lemma closure_mul_image_eq_top
  (hR : R ∈ right_transversals (H : set G)) (hR1 : (1 : G) ∈ R) (hS : closure S = ⊤) :
  closure ((R * S).image (λ g, ⟨g * (to_fun hR g)⁻¹, mul_inv_to_fun_mem hR g⟩) : set H) = ⊤ :=
begin
  rw [eq_top_iff, ←map_subtype_le_map_subtype, monoid_hom.map_closure, set.image_image],
  exact (map_subtype_le ⊤).trans (ge_of_eq (closure_mul_image_eq hR hR1 hS)),
end

/-- **Schreier's Lemma**: If `R : finset G` is a right_transversal of `H : subgroup G`
  with `1 ∈ R`, and if `G` is generated by `S : finset G`, then `H` is generated by the `finset`
  `(R * S).image (λ g, g * (to_fun hR g)⁻¹)`. -/
lemma closure_mul_image_eq_top' [decidable_eq G] {R S : finset G}
  (hR : (R : set G) ∈ right_transversals (H : set G)) (hR1 : (1 : G) ∈ R)
  (hS : closure (S : set G) = ⊤) :
  closure ((((R * S).image (λ g, ⟨_, mul_inv_to_fun_mem hR g⟩)) : finset H) : set H) = ⊤ :=
begin
  rw [finset.coe_image, finset.coe_mul],
  exact closure_mul_image_eq_top hR hR1 hS,
end

variables (H)

lemma exists_finset_card_le_mul [finite_index H] {S : finset G} (hS : closure (S : set G) = ⊤) :
  ∃ T : finset H, T.card ≤ H.index * S.card ∧ closure (T : set H) = ⊤ :=
begin
  letI := H.fintype_quotient_of_finite_index,
  haveI : decidable_eq G := classical.dec_eq G,
  obtain ⟨R₀, hR : R₀ ∈ right_transversals (H : set G), hR1⟩ := exists_right_transversal (1 : G),
  haveI : fintype R₀ := fintype.of_equiv _ (mem_right_transversals.to_equiv hR),
  let R : finset G := set.to_finset R₀,
  replace hR : (R : set G) ∈ right_transversals (H : set G) := by rwa set.coe_to_finset,
  replace hR1 : (1 : G) ∈ R := by rwa set.mem_to_finset,
  refine ⟨_, _, closure_mul_image_eq_top' hR hR1 hS⟩,
  calc _ ≤ (R * S).card : finset.card_image_le
  ... ≤ (R ×ˢ S).card : finset.card_image_le
  ... = R.card * S.card : R.card_product S
  ... = H.index * S.card : congr_arg (* S.card) _,
  calc R.card = fintype.card R : (fintype.card_coe R).symm
  ... = _ : (fintype.card_congr (mem_right_transversals.to_equiv hR)).symm
  ... = fintype.card (G ⧸ H) : quotient_group.card_quotient_right_rel H
  ... = H.index : H.index_eq_card.symm,
end

/-- **Schreier's Lemma**: A finite index subgroup of a finitely generated
  group is finitely generated. -/
instance fg_of_index_ne_zero [hG : group.fg G] [finite_index H] : group.fg H :=
begin
  obtain ⟨S, hS⟩ := hG.1,
  obtain ⟨T, -, hT⟩ := exists_finset_card_le_mul H hS,
  exact ⟨⟨T, hT⟩⟩,
end

lemma rank_le_index_mul_rank [hG : group.fg G] [finite_index H] :
  group.rank H ≤ H.index * group.rank G :=
begin
  haveI := H.fg_of_index_ne_zero,
  obtain ⟨S, hS₀, hS⟩ := group.rank_spec G,
  obtain ⟨T, hT₀, hT⟩ := exists_finset_card_le_mul H hS,
  calc group.rank H ≤ T.card : group.rank_le H hT
  ... ≤ H.index * S.card : hT₀
  ... = H.index * group.rank G : congr_arg ((*) H.index) hS₀,
end

variables (G)

/-- If `G` has `n` commutators `[g₁, g₂]`, then `|G'| ∣ [G : Z(G)] ^ ([G : Z(G)] * n + 1)`,
where `G'` denotes the commutator of `G`. -/
lemma card_commutator_dvd_index_center_pow [finite (commutator_set G)] :
  nat.card (commutator G) ∣
    (center G).index ^ ((center G).index * nat.card (commutator_set G) + 1) :=
begin
  -- First handle the case when `Z(G)` has infinite index and `[G : Z(G)]` is defined to be `0`
  by_cases hG : (center G).index = 0,
  { simp_rw [hG, zero_mul, zero_add, pow_one, dvd_zero] },
  haveI : finite_index (center G) := ⟨hG⟩,
  -- Rewrite as `|Z(G) ∩ G'| * [G' : Z(G) ∩ G'] ∣ [G : Z(G)] ^ ([G : Z(G)] * n) * [G : Z(G)]`
  rw [←((center G).subgroup_of (commutator G)).card_mul_index, pow_succ'],
  -- We have `h1 : [G' : Z(G) ∩ G'] ∣ [G : Z(G)]`
  have h1 := relindex_dvd_index_of_normal (center G) (commutator G),
  -- So we can reduce to proving `|Z(G) ∩ G'| ∣ [G : Z(G)] ^ ([G : Z(G)] * n)`
  refine mul_dvd_mul _ h1,
  -- We know that `[G' : Z(G) ∩ G'] < ∞` by `h1` and `hG`
  haveI : finite_index ((center G).subgroup_of (commutator G)) := ⟨ne_zero_of_dvd_ne_zero hG h1⟩,
  -- We have `h2 : rank (Z(G) ∩ G') ≤ [G' : Z(G) ∩ G'] * rank G'` by Schreier's lemma
  have h2 := rank_le_index_mul_rank ((center G).subgroup_of (commutator G)),
  -- We have `h3 : [G' : Z(G) ∩ G'] * rank G' ≤ [G : Z(G)] * n` by `h1` and `rank G' ≤ n`
  have h3 := nat.mul_le_mul (nat.le_of_dvd (nat.pos_of_ne_zero hG) h1) (rank_commutator_le_card G),
  -- So we can reduce to proving `|Z(G) ∩ G'| ∣ [G : Z(G)] ^ rank (Z(G) ∩ G')`
  refine dvd_trans _ (pow_dvd_pow (center G).index (h2.trans h3)),
  -- `Z(G) ∩ G'` is abelian, so it enough to prove that `g ^ [G : Z(G)] = 1` for `g ∈ Z(G) ∩ G'`
  apply card_dvd_exponent_pow_rank' _ (λ g, _),
  -- `Z(G)` is abelian, so `g ∈ Z(G) ∩ G' ≤ G' ≤ ker (transfer : G → Z(G))`
  have := abelianization.commutator_subset_ker (monoid_hom.transfer_center_pow G) g.1.2,
  -- `transfer g` is defeq to `g ^ [G : Z(G)]`, so we are done
  simpa only [monoid_hom.mem_ker, subtype.ext_iff] using this,
end

/-- A bound for the size of the commutator subgroup in terms of the number of commutators. -/
def card_commutator_bound (n : ℕ) := (n ^ (2 * n)) ^ (n ^ (2 * n + 1) + 1)

/-- A theorem of Schur: The size of the commutator subgroup is bounded in terms of the number of
  commutators. -/
lemma card_commutator_le_of_finite_commutator_set [finite (commutator_set G)] :
  nat.card (commutator G) ≤ card_commutator_bound (nat.card (commutator_set G)) :=
begin
  have h1 := index_center_le_pow (closure_commutator_representatives G),
  have h2 := card_commutator_dvd_index_center_pow (closure_commutator_representatives G),
  rw card_commutator_set_closure_commutator_representatives at h1 h2,
  rw card_commutator_closure_commutator_representatives at h2,
  replace h1 := h1.trans (nat.pow_le_pow_of_le_right finite.card_pos
    (rank_closure_commutator_representations_le G)),
  replace h2 := h2.trans (pow_dvd_pow _ (add_le_add_right (mul_le_mul_right' h1 _) 1)),
  rw ← pow_succ' at h2,
  refine (nat.le_of_dvd _ h2).trans (nat.pow_le_pow_of_le_left h1 _),
  exact pow_pos (nat.pos_of_ne_zero finite_index.finite_index) _,
end

/-- A theorem of Schur: A group with finitely many commutators has finite commutator subgroup. -/
instance [finite (commutator_set G)] : finite (commutator G) :=
begin
  have h2 := card_commutator_dvd_index_center_pow (closure_commutator_representatives G),
  refine nat.finite_of_card_ne_zero (λ h, _),
  rw [card_commutator_closure_commutator_representatives, h, zero_dvd_iff] at h2,
  exact finite_index.finite_index (pow_eq_zero h2),
end

end subgroup


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.arrow

/-!
# Strong epimorphisms

In this file, we define strong epimorphisms. A strong epimorphism is an epimorphism `f`, such
that for every commutative square with `f` at the top and a monomorphism at the bottom, there is
a diagonal morphism making the two triangles commute. This lift is necessarily unique (as shown in
`comma.lean`).

## Main results

Besides the definition, we show that
* the composition of two strong epimorphisms is a strong epimorphism,
* if `f ≫ g` is a strong epimorphism, then so is `g`,
* if `f` is both a strong epimorphism and a monomorphism, then it is an isomorphism

## Future work

There is also the dual notion of strong monomorphism.

## References

* [F. Borceux, *Handbook of Categorical Algebra 1*][borceux-vol1]
-/

universes v u

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

variables {P Q : C}

/-- A strong epimorphism `f` is an epimorphism such that every commutative square with `f` at the
    top and a monomorphism at the bottom has a lift. -/
class strong_epi (f : P ⟶ Q) : Prop :=
(epi : epi f)
(has_lift : Π {X Y : C} {u : P ⟶ X} {v : Q ⟶ Y} {z : X ⟶ Y} [mono z] (h : u ≫ z = f ≫ v),
  arrow.has_lift $ arrow.hom_mk' h)

attribute [instance] strong_epi.has_lift

@[priority 100]
instance epi_of_strong_epi (f : P ⟶ Q) [strong_epi f] : epi f := strong_epi.epi

section
variables {R : C} (f : P ⟶ Q) (g : Q ⟶ R)

/-- The composition of two strong epimorphisms is a strong epimorphism. -/
lemma strong_epi_comp [strong_epi f] [strong_epi g] : strong_epi (f ≫ g) :=
{ epi := epi_comp _ _,
  has_lift :=
  begin
    introsI,
    have h₀ : u ≫ z = f ≫ g ≫ v, by simpa [category.assoc] using h,
    let w : Q ⟶ X := arrow.lift (arrow.hom_mk' h₀),
    have h₁ : w ≫ z = g ≫ v, by rw arrow.lift_mk'_right,
    exact arrow.has_lift.mk ⟨(arrow.lift (arrow.hom_mk' h₁) : R ⟶ X), by simp, by simp⟩
  end }

/-- If `f ≫ g` is a strong epimorphism, then so is g. -/
lemma strong_epi_of_strong_epi [strong_epi (f ≫ g)] : strong_epi g :=
{ epi := epi_of_epi f g,
  has_lift :=
  begin
    introsI,
    have h₀ : (f ≫ u) ≫ z = (f ≫ g) ≫ v, by simp only [category.assoc, h],
    exact arrow.has_lift.mk
      ⟨(arrow.lift (arrow.hom_mk' h₀) : R ⟶ X), (cancel_mono z).1 (by simp [h]), by simp⟩,
  end }

/-- An isomorphism is in particular a strong epimorphism. -/
@[priority 100] instance strong_epi_of_is_iso [is_iso f] : strong_epi f :=
{ epi := by apply_instance,
  has_lift := λ X Y u v z _ h, arrow.has_lift.mk ⟨inv f ≫ u, by simp, by simp [h]⟩ }

end

/-- A strong epimorphism that is a monomorphism is an isomorphism. -/
lemma is_iso_of_mono_of_strong_epi (f : P ⟶ Q) [mono f] [strong_epi f] : is_iso f :=
⟨⟨arrow.lift $ arrow.hom_mk' $ show 𝟙 P ≫ f = f ≫ 𝟙 Q, by simp, by tidy⟩⟩

end category_theory


import ProofMining.FiniteType
import ProofMining.Util

abbrev Environment := List FiniteType

inductive Term
| var : Nat → Term
| app : Term → Term → Term
| zero : Term
| successor : Term
| kcomb : FiniteType → FiniteType → Term
| scomb : FiniteType → FiniteType → FiniteType → Term
| recursorOne: FiniteType → Term
deriving DecidableEq, Inhabited

namespace Term

instance : Coe Nat Term := ⟨var⟩

infixl:80 " # " => app
notation "K" => kcomb
notation "S" => scomb
notation "R" => recursorOne

def shift (place : Nat) (cutoff : Nat := 0) : Term → Term :=
fun term => match term with
| var i => if i < cutoff then var i else var $ i + place
| app t u => app (t.shift place cutoff) (u.shift place cutoff)
| zero => zero
| successor => successor
| kcomb ρ σ => kcomb ρ σ
| scomb ρ σ τ => scomb ρ σ τ
| recursorOne ρ => recursorOne ρ

def subst : Term → Nat → Term → Term
| var j, i, s => if i = j then s else j
| app t u, i, s => app (t.subst i s) (u.subst i s)
| zero, _, _ => zero
| successor, _, _ => successor
| kcomb ρ σ, _, _ => kcomb ρ σ
| scomb ρ σ τ, _, _ => scomb ρ σ τ
| recursorOne ρ, _, _ => recursorOne ρ

inductive WellTyped (env : Environment) : Term → FiniteType → Prop
| var (i σ) : env.nth i = some σ → WellTyped env (var i) σ
| app (t u) (ρ τ) : WellTyped env t (ρ ↣ τ) → WellTyped env u ρ → WellTyped env (app t u) τ
| zero : WellTyped env zero 0
| successor : WellTyped env successor 1
| kcomb (ρ σ) : WellTyped env (kcomb ρ σ) (ρ ↣ σ ↣ ρ)
| scomb (ρ σ τ) : WellTyped env (scomb ρ σ τ) ((ρ ↣ σ ↣ τ) ↣ (ρ ↣ σ) ↣ ρ ↣ τ)
| recursorOne ρ : WellTyped env (recursorOne ρ) (ρ ↣ (ρ ↣ 0 ↣ ρ) ↣ 0 ↣ ρ)

notation env " ⊢ʷᵗ " t " : " ρ:max => WellTyped env t ρ

@[simp]
def inferTypeAppAux : Option FiniteType → Option FiniteType → Option FiniteType
| ρ ↣ τ, σ => if ρ = σ then some τ else none
| _, _ => none

@[simp]
def inferType : Environment → Term → Option FiniteType
  | env, var x => List.nth env x
  | env, app x y => inferTypeAppAux (inferType env x) (inferType env y)
  | env, zero => some (FiniteType.zero)
  | env, successor => some (FiniteType.zero ↣ FiniteType.zero)
  | env, kcomb ρ σ => some (ρ ↣ σ ↣ ρ)
  | env, scomb ρ σ τ => some ((ρ ↣ σ ↣ τ) ↣ (ρ ↣ σ) ↣ ρ ↣ τ)
  | env, recursorOne ρ => some $ (ρ ↣ (ρ ↣ 0 ↣ ρ) ↣ 0 ↣ ρ)

def getAppSource {env : Environment} {u v : Term} {σ : FiniteType} :
  inferType env (u # v) = some σ → FiniteType :=
  fun h => let ρ := inferType env u
  match h':ρ with
  | ρ₁ ↣ ρ₂ => ρ₁
  | 𝕆 => False.elim (by simp [*] at h)
  | none => False.elim (by simp [*] at h)

theorem app_source_correct {env : Environment} {u v : Term} {σ : FiniteType} (h : inferType env (u # v) = some σ):
  inferType env v = some (getAppSource h) ∧ inferType env u = some ((getAppSource h) ↣ σ) := sorry

theorem infer_type_iff_well_typed {env : Environment} {t : Term} {σ : FiniteType} :
  WellTyped env t σ ↔ inferType env t = some σ := by
  apply Iff.intro
  . intros wt
    induction wt with
    | app _ _ _ _ _ _ h₁ h₂ =>
      simp [inferType, h₂, h₁]
    | var i _ h =>
      simp only [inferType]
      exact h
    | _ => simp only [inferType]
  . intros h
    induction t generalizing σ with
    | var i =>
      simp only [inferType] at h
      constructor
      assumption
    | app u v ihu ihv =>
      have := app_source_correct h
      cases this with | intro hρl hρr =>
      specialize ihu hρr
      specialize ihv hρl
      constructor <;> assumption
    | _ =>
      simp [inferType] at h
      try { rw [←h]; constructor }

@[simp]
def isWellTyped (env : Environment) (t : Term) := Option.isSome $ inferType env t

def getAppSource' {env : Environment} {u v : Term} {σ : FiniteType} : WellTyped env (u # v) σ → FiniteType :=
  fun wt => getAppSource $ infer_type_iff_well_typed.mp wt

theorem app_source_correct' {env : Environment} {u v : Term} {σ : FiniteType} (h : WellTyped env (u # v) σ):
  WellTyped env v (getAppSource' h) ∧ WellTyped env u (getAppSource' h ↣ σ) := sorry

theorem unique_typing : WellTyped e t ρ → WellTyped e t σ → ρ = σ := by
  intros wtρ wtσ
  rw [infer_type_iff_well_typed] at wtρ wtσ
  have : some ρ = some σ := Eq.trans wtρ.symm wtσ
  cases this
  rfl

theorem subst_well_typed {env} {t s} {ρ σ} {i} :
  WellTyped env t ρ → env.nth i = some σ → WellTyped env s σ → WellTyped env (t.subst i s) ρ := by
  intros wtt wti wts
  induction t generalizing ρ with
  | var j =>
    byCases h : i = j
    . rw [h] at wti ⊢
      cases wtt
      have : some σ = some ρ := Eq.trans wti.symm (by assumption)
      cases this
      simp [*, subst]
    . simp [*, subst]
  | app u v ihu ihv =>
    cases wtt with
    | app _ _ τ _ wtu wtv =>
    exact WellTyped.app _ _ _ _ (ihu wtu) (ihv wtv)
  | _ =>
    simp [*, subst]
#check @subst_well_typed

def idcomb (ρ : FiniteType) : Term := S ρ (0 ↣ ρ) ρ # K ρ (0 ↣ ρ) # K ρ 0
notation "I" => idcomb

@[simp]
def reduceOneStep : Term → Term
| K _ _ # t # _ => t
| S _ _ _ # t # u # v => t # v # (u # v)
| t # u => t.reduceOneStep # u.reduceOneStep
| x => x


-- Idea: pq-like is always with a normal sub-power quandle

import sub_pq
import pq_to_group
import pq_induction_principles

universe u

section sub_pq_normal

variables {Q : Type u} [power_quandle Q]

def sub_pq_normal (Q1 : sub_power_quandle Q) : Prop := ∀ x : Q, ∀ y : Q1, x ▷ y ∈ Q1.carrier

variables {Q1 : sub_power_quandle Q}

def normal_rhd (hQ1 : sub_pq_normal Q1) (x : Q) (y : Q1) : Q1 := ⟨x ▷ y, hQ1 x y⟩

lemma normal_rhd_def (hQ1 : sub_pq_normal Q1) (x : Q) (y : Q1) : normal_rhd hQ1 x y = ⟨x ▷ y, hQ1 x y⟩ := rfl

end sub_pq_normal

section sub_pq_normal_pq_injective

variables {Q : Type u} [power_quandle Q]

variables {Q1 : sub_power_quandle Q}

def sub_pq_group_inclusion : pq_group Q1 →* pq_group Q :=
begin
  fapply L_of_morph,
  {
    intro q,
    cases q with q hq,
    exact q,
  },
  {
    split,
    {
      intros a b,
      cases a with a ha,
      cases b with b hb,
      refl,
    },
    {
      intros a n,
      cases a with a ha,
      refl,
    },
  }
end

theorem pq_group_normal (hQ1 : sub_pq_normal Q1) (x : pq_group Q) (y : pq_group Q1) : ∃ z : pq_group Q1, (x ▷ (sub_pq_group_inclusion y)) = sub_pq_group_inclusion z :=
begin
  revert x,
  refine pq_group_word_induction _ _,
  {
    use y,
    rw power_quandle.one_rhd,
  },
  {
    intros x a hxy,
    cases hxy with z1 hz1,
    rw mul_rhd,
    rw hz1,
    clear hz1 x y,
    revert z1,
    refine pq_group_word_induction _ _,
    {
      use 1,
      simp only [monoid_hom.map_one],
      rw power_quandle.rhd_one,
    },
    {
      intros x b hxz1,
      cases hxz1 with y hy,
      simp only [monoid_hom.map_mul],
      rw rhd_mul,
      rw hy,
      have hinclb : sub_pq_group_inclusion (of b) = of (↑b),
      {
        unfold sub_pq_group_inclusion,
        rw L_of_morph_of,
        apply congr_arg,
        cases b with b hb,
        simp only [subtype.coe_mk],
      },
      rw hinclb,
      rw rhd_of_eq_of_rhd,
      use (of (normal_rhd hQ1 a b) * y),
      simp only [monoid_hom.map_mul, mul_left_inj],
      refl,
    },
  },
end

end sub_pq_normal_pq_injective


import tactic

variable {α : Type*}
variables (s t u : set α)

open set

example (h : s ⊆ t) : s ∩ u ⊆ t ∩ u :=
begin
  intros x xsu,
  exact ⟨h xsu.1, xsu.2⟩,
end

/- Alternatively -/
example (h : s ⊆ t) : s ∩ u ⊆ t ∩ u :=
by exact λ x ⟨xs, xu⟩, ⟨h xs, xu⟩


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

import category_theory.abelian.opposite
import category_theory.abelian.homology
import algebra.homology.additive

/-!
# Opposite categories of complexes
Given a preadditive category `V`, the opposite of its category of chain complexes is equivalent to
the category of cochain complexes of objects in `Vᵒᵖ`. We define this equivalence, and another
analagous equivalence (for a general category of homological complexes with a general
complex shape).

We then show that when `V` is abelian, if `C` is a homological complex, then the homology of
`op(C)` is isomorphic to `op` of the homology of `C` (and the analagous result for `unop`).

## Implementation notes
It is convenient to define both `op` and `op_symm`; this is because given a complex shape `c`,
`c.symm.symm` is not defeq to `c`.

## Tags
opposite, chain complex, cochain complex, homology, cohomology, homological complex
-/

noncomputable theory

open opposite category_theory category_theory.limits

section

variables {V : Type*} [category V] [abelian V]

lemma image_to_kernel_op {X Y Z : V} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
  image_to_kernel g.op f.op (by rw [←op_comp, w, op_zero]) = ((image_subobject_iso _)
  ≪≫ (image_op_op _).symm).hom ≫ (cokernel.desc f (factor_thru_image g)
    (by rw [←cancel_mono (image.ι g), category.assoc, image.fac, w, zero_comp])).op
  ≫ ((kernel_subobject_iso _) ≪≫ (kernel_op_op _)).inv :=
begin
  ext,
  simpa only [iso.trans_hom, iso.symm_hom, iso.trans_inv, kernel_op_op_inv, category.assoc,
    image_to_kernel_arrow, kernel_subobject_arrow', kernel.lift_ι, ←op_comp, cokernel.π_desc,
    ←image_subobject_arrow, ←image_unop_op_inv_comp_op_factor_thru_image g.op],
end

lemma image_to_kernel_unop {X Y Z : Vᵒᵖ} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
  image_to_kernel g.unop f.unop (by rw [←unop_comp, w, unop_zero]) = ((image_subobject_iso _)
  ≪≫ (image_unop_unop _).symm).hom ≫ (cokernel.desc f (factor_thru_image g)
    (by rw [←cancel_mono (image.ι g), category.assoc, image.fac, w, zero_comp])).unop
  ≫ ((kernel_subobject_iso _) ≪≫ (kernel_unop_unop _)).inv :=
begin
  ext,
  dunfold image_unop_unop,
  simp only [iso.trans_hom, iso.symm_hom, iso.trans_inv, kernel_unop_unop_inv, category.assoc,
    image_to_kernel_arrow, kernel_subobject_arrow', kernel.lift_ι, cokernel.π_desc,
    iso.unop_inv, ←unop_comp, factor_thru_image_comp_image_unop_op_inv, quiver.hom.unop_op,
    image_subobject_arrow],
end

/-- Given `f, g` with `f ≫ g = 0`, the homology of `g.op, f.op` is the opposite of the homology of
`f, g`. -/
def homology_op {X Y Z : V} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
   homology g.op f.op (by rw [←op_comp, w, op_zero]) ≅ opposite.op (homology f g w) :=
cokernel_iso_of_eq (image_to_kernel_op _ _ w) ≪≫ (cokernel_epi_comp _ _)
  ≪≫ cokernel_comp_is_iso _ _ ≪≫ cokernel_op_op _ ≪≫ ((homology_iso_kernel_desc _ _ _)
  ≪≫ (kernel_iso_of_eq (by ext; simp only [image.fac, cokernel.π_desc, cokernel.π_desc_assoc]))
  ≪≫ (kernel_comp_mono _ (image.ι g))).op

/-- Given morphisms `f, g` in `Vᵒᵖ` with `f ≫ g = 0`, the homology of `g.unop, f.unop` is the
opposite of the homology of `f, g`. -/
def homology_unop {X Y Z : Vᵒᵖ} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
  homology g.unop f.unop (by rw [←unop_comp, w, unop_zero]) ≅ opposite.unop (homology f g w) :=
cokernel_iso_of_eq (image_to_kernel_unop _ _ w) ≪≫ (cokernel_epi_comp _ _)
  ≪≫ cokernel_comp_is_iso _ _ ≪≫ cokernel_unop_unop _
  ≪≫ ((homology_iso_kernel_desc _ _ _)
  ≪≫ (kernel_iso_of_eq (by ext; simp only [image.fac, cokernel.π_desc, cokernel.π_desc_assoc]))
  ≪≫ (kernel_comp_mono _ (image.ι g))).unop

end

namespace homological_complex

variables {ι V : Type*} [category V] {c : complex_shape ι}

section
variables [preadditive V]

/-- Sends a complex `X` with objects in `V` to the corresponding complex with objects in `Vᵒᵖ`. -/
@[simps] protected def op (X : homological_complex V c) : homological_complex Vᵒᵖ c.symm :=
{ X := λ i, op (X.X i),
  d := λ i j, (X.d j i).op,
  shape' := λ i j hij, by { rw [X.shape j i hij, op_zero], },
  d_comp_d' := by { intros, rw [← op_comp, X.d_comp_d, op_zero], } }

/-- Sends a complex `X` with objects in `V` to the corresponding complex with objects in `Vᵒᵖ`. -/
@[simps] protected def op_symm (X : homological_complex V c.symm) : homological_complex Vᵒᵖ c :=
{ X := λ i, op (X.X i),
  d := λ i j, (X.d j i).op,
  shape' := λ i j hij, by { rw [X.shape j i hij, op_zero], },
  d_comp_d' := by { intros, rw [← op_comp, X.d_comp_d, op_zero], } }

/-- Sends a complex `X` with objects in `Vᵒᵖ` to the corresponding complex with objects in `V`. -/
@[simps] protected def unop (X : homological_complex Vᵒᵖ c) : homological_complex V c.symm :=
{ X := λ i, unop (X.X i),
  d := λ i j, (X.d j i).unop,
  shape' := λ i j hij, by { rw [X.shape j i hij, unop_zero], },
  d_comp_d' := by { intros, rw [← unop_comp, X.d_comp_d, unop_zero], } }

/-- Sends a complex `X` with objects in `Vᵒᵖ` to the corresponding complex with objects in `V`. -/
@[simps] protected def unop_symm (X : homological_complex Vᵒᵖ c.symm) : homological_complex V c :=
{ X := λ i, unop (X.X i),
  d := λ i j, (X.d j i).unop,
  shape' := λ i j hij, by { rw [X.shape j i hij, unop_zero], },
  d_comp_d' := by { intros, rw [← unop_comp, X.d_comp_d, unop_zero], } }

variables (V c)

/-- Auxilliary definition for `op_equivalence`. -/
@[simps] def op_functor : (homological_complex V c)ᵒᵖ ⥤ homological_complex Vᵒᵖ c.symm :=
{ obj := λ X, (unop X).op,
  map := λ X Y f,
  { f := λ i, (f.unop.f i).op,
    comm' := λ i j hij, by simp only [op_d, ← op_comp, f.unop.comm] }, }

/-- Auxilliary definition for `op_equivalence`. -/
@[simps] def op_inverse : homological_complex Vᵒᵖ c.symm ⥤ (homological_complex V c)ᵒᵖ :=
{ obj := λ X, op X.unop_symm,
  map := λ X Y f, quiver.hom.op
  { f := λ i, (f.f i).unop,
    comm' := λ i j hij, by simp only [unop_symm_d, ←unop_comp, f.comm], }}

/-- Auxilliary definition for `op_equivalence`. -/
def op_unit_iso : 𝟭 (homological_complex V c)ᵒᵖ ≅ op_functor V c ⋙ op_inverse V c :=
nat_iso.of_components (λ X, (homological_complex.hom.iso_of_components (λ i, iso.refl _)
  (λ i j hij, by simp only [iso.refl_hom, category.id_comp, unop_symm_d, op_d, quiver.hom.unop_op,
        category.comp_id]) : (opposite.unop X).op.unop_symm ≅ unop X).op)
  begin
    intros X Y f,
    refine quiver.hom.unop_inj _,
    ext,
    simp only [quiver.hom.unop_op, functor.id_map, iso.op_hom, functor.comp_map,
      unop_comp, comp_f, hom.iso_of_components_hom_f],
    erw [category.id_comp, category.comp_id (f.unop.f x)],
  end

/-- Auxilliary definition for `op_equivalence`. -/
def op_counit_iso : op_inverse V c ⋙ op_functor V c ≅ 𝟭 (homological_complex Vᵒᵖ c.symm) :=
nat_iso.of_components (λ X, homological_complex.hom.iso_of_components (λ i, iso.refl _)
  (λ i j hij, by simpa only [iso.refl_hom, category.id_comp, category.comp_id]))
  begin
    intros X Y f,
    ext,
    simpa only [quiver.hom.unop_op, quiver.hom.op_unop, functor.comp_map, functor.id_map,
      iso.refl_hom, category.id_comp, category.comp_id, comp_f, hom.iso_of_components_hom_f],
  end

/-- Given a category of complexes with objects in `V`, there is a natural equivalence between its
opposite category and a category of complexes with objects in `Vᵒᵖ`. -/
@[simps] def op_equivalence : (homological_complex V c)ᵒᵖ ≌ homological_complex Vᵒᵖ c.symm :=
{ functor := op_functor V c,
  inverse := op_inverse V c,
  unit_iso := op_unit_iso V c,
  counit_iso := op_counit_iso V c,
  functor_unit_iso_comp' :=
  begin
    intro X,
    ext,
    simp only [op_unit_iso, op_counit_iso, nat_iso.of_components_hom_app, iso.op_hom,
      comp_f, op_functor_map_f, quiver.hom.unop_op, hom.iso_of_components_hom_f],
    exact category.comp_id _,
  end }

/-- Auxilliary definition for `unop_equivalence`. -/
@[simps] def unop_functor : (homological_complex Vᵒᵖ c)ᵒᵖ ⥤ homological_complex V c.symm :=
{ obj := λ X, (unop X).unop,
  map := λ X Y f,
  { f := λ i, (f.unop.f i).unop,
    comm' := λ i j hij, by simp only [unop_d, ← unop_comp, f.unop.comm] }, }

/-- Auxilliary definition for `unop_equivalence`. -/
@[simps] def unop_inverse : homological_complex V c.symm ⥤ (homological_complex Vᵒᵖ c)ᵒᵖ :=
{ obj := λ X, op X.op_symm,
  map := λ X Y f, quiver.hom.op
  { f := λ i, (f.f i).op,
    comm' := λ i j hij, by simp only [op_symm_d, ←op_comp, f.comm], }}

/-- Auxilliary definition for `unop_equivalence`. -/
def unop_unit_iso : 𝟭 (homological_complex Vᵒᵖ c)ᵒᵖ ≅ unop_functor V c ⋙ unop_inverse V c :=
nat_iso.of_components (λ X, (homological_complex.hom.iso_of_components (λ i, iso.refl _)
  (λ i j hij, by simp only [iso.refl_hom, category.id_comp, unop_symm_d, op_d, quiver.hom.unop_op,
        category.comp_id]) : (opposite.unop X).op.unop_symm ≅ unop X).op)
  begin
    intros X Y f,
    refine quiver.hom.unop_inj _,
    ext,
    simp only [quiver.hom.unop_op, functor.id_map, iso.op_hom, functor.comp_map,
      unop_comp, comp_f, hom.iso_of_components_hom_f],
    erw [category.id_comp, category.comp_id (f.unop.f x)],
  end

/-- Auxilliary definition for `unop_equivalence`. -/
def unop_counit_iso : unop_inverse V c ⋙ unop_functor V c ≅ 𝟭 (homological_complex V c.symm) :=
nat_iso.of_components (λ X, homological_complex.hom.iso_of_components (λ i, iso.refl _)
  (λ i j hij, by simpa only [iso.refl_hom, category.id_comp, category.comp_id]))
  begin
    intros X Y f,
    ext,
    simpa only [quiver.hom.unop_op, quiver.hom.op_unop, functor.comp_map, functor.id_map,
      iso.refl_hom, category.id_comp, category.comp_id, comp_f, hom.iso_of_components_hom_f],
  end

/-- Given a category of complexes with objects in `Vᵒᵖ`, there is a natural equivalence between its
opposite category and a category of complexes with objects in `V`. -/
@[simps] def unop_equivalence : (homological_complex Vᵒᵖ c)ᵒᵖ ≌ homological_complex V c.symm :=
{ functor := unop_functor V c,
  inverse := unop_inverse V c,
  unit_iso := unop_unit_iso V c,
  counit_iso := unop_counit_iso V c,
  functor_unit_iso_comp' :=
  begin
    intro X,
    ext,
    simp only [op_unit_iso, op_counit_iso, nat_iso.of_components_hom_app, iso.op_hom,
      comp_f, op_functor_map_f, quiver.hom.unop_op, hom.iso_of_components_hom_f],
    exact category.comp_id _,
  end }

variables {V c}
instance op_functor_additive : (@op_functor ι V _ c _).additive := {}

instance unop_functor_additive : (@unop_functor ι V _ c _).additive := {}

end

variables [abelian V] (C : homological_complex V c) (i : ι)

/-- Auxilliary tautological definition for `homology_op`. -/
def homology_op_def :
  C.op.homology i ≅ _root_.homology (C.d_from i).op (C.d_to i).op
    (by rw [←op_comp, C.d_to_comp_d_from i, op_zero]) := iso.refl _

/-- Given a complex `C` of objects in `V`, the `i`th homology of its 'opposite' complex (with
objects in `Vᵒᵖ`) is the opposite of the `i`th homology of `C`. -/
def homology_op : C.op.homology i ≅ opposite.op (C.homology i) :=
homology_op_def _ _ ≪≫ homology_op _ _ _

/-- Auxilliary tautological definition for `homology_unop`. -/
def homology_unop_def (C : homological_complex Vᵒᵖ c) :
  C.unop.homology i ≅ _root_.homology (C.d_from i).unop (C.d_to i).unop
    (by rw [←unop_comp, C.d_to_comp_d_from i, unop_zero]) := iso.refl _

/-- Given a complex `C` of objects in `Vᵒᵖ`, the `i`th homology of its 'opposite' complex (with
objects in `V`) is the opposite of the `i`th homology of `C`. -/
def homology_unop (C : homological_complex Vᵒᵖ c) :
  C.unop.homology i ≅ opposite.unop (C.homology i) :=
homology_unop_def _ _ ≪≫ homology_unop _ _ _

end homological_complex