import buchberger rtc wf_mv_polynomial

open mv_polynomial
open finsupp

namespace buch
variables {σ : Type*} {α : Type*} [decidable_eq σ] [decidable_eq α] [fintype σ] [decidable_linear_order (σ →₀ ℕ)]
variables [discrete_field α] [is_well_founded (σ →₀ ℕ) (<)] [is_monomial_order (σ →₀ ℕ) (≤)]

section reduction
variables (s : finset (mv_polynomial σ α)) {S : finset (mv_polynomial σ α)}

inductive red_one_step : mv_polynomial σ α → mv_polynomial σ α → Prop
| cons : ∀ {p r : mv_polynomial σ α}, p ≠ 0 → red_one_step p.TL r.TL → p.LT = r.LT → red_one_step p r
| red_LM : ∀ {p r : mv_polynomial σ α}, p ≠ 0 →
    (∃ (q : mv_polynomial σ α) (h₁ : q ∈ s) (h₂ : q ≠ 0)  (h₃ : q.LM ∣ p.LM), reduction p q = r) → red_one_step p r

def reducible (p : mv_polynomial σ α) :=
    ∃ (q : mv_polynomial σ α) (hq₁ : q ∈ s) (hq₂ : q ≠ 0) (pₜ : σ →₀ ℕ) (hp : pₜ ∈ p.support), q.LM ∣ pₜ
def is_red_rel (p r : mv_polynomial σ α) :=
    ∃ (q : mv_polynomial σ α) (hq₁ : q ∈ s) (hq₂ : q ≠ 0) (pₜ : σ →₀ ℕ) (hp : pₜ ∈ p.support) (hqpₜ : q.LM ∣ pₜ),
        r = p - q * monomial (pₜ - q.LM) (p pₜ / q.LC)

notation a `→[` S `]` b := red_one_step S a b
notation a `↛[` S `]` b := ¬ red_one_step S a b

def red_plus : mv_polynomial σ α → mv_polynomial σ α → Prop := rtc (red_one_step s)
notation a `→[` S `]+` b := red_plus S a b
notation a `↛[` S `]+` b := ¬ red_plus S a b

def irreducible (p : mv_polynomial σ α) := ∀ (q : mv_polynomial σ α) (hq₁ : q ∈ s) (hq₂ : q ≠ 0) (pₜ ∈ p.support), q.LM ∤ pₜ

notation a `→[` S `]*` b := red_plus S a b ∧ irreducible S b

instance irreducible_decidable (p : mv_polynomial σ α) : decidable (irreducible s p) := finset.decidable_dforall_finset
instance reducible_decidable (p : mv_polynomial σ α) : decidable (reducible s p) := finset.decidable_dexists_finset

@[simp] lemma irred_not_red {p : mv_polynomial σ α} : irreducible s p ↔ ¬ reducible s p := by simp [irreducible, reducible]
lemma red_not_irred {p : mv_polynomial σ α} : ¬ irreducible s p ↔ reducible s p := by simp [irred_not_red]

lemma zero_irreducible : irreducible S 0 := by simp [irreducible]
lemma zero_not_reducible : ¬ reducible S 0 := by rw ←irred_not_red; exact zero_irreducible
lemma zero_not_is_red_rel : ∀ {r}, ¬ is_red_rel S 0 r := by simp [is_red_rel]

lemma red_one_step_is_red_rel {p r : mv_polynomial σ α} : (p →[S] r) ↔ is_red_rel S p r :=
⟨λ h, begin
    induction h with p r hp hpr₁ hpr₂ ih p r hp h,
    {
        rcases ih with ⟨q, hq₁, hq₂, pₜ, hpₜ, hqpₜ, h⟩,
        rw [←@add_left_cancel_iff _ _ p.LT, ←add_sub_assoc, LM_TL_eq p, hpr₂, LM_TL_eq r, TL_apply_mem hpₜ] at h,
        refine ⟨q, hq₁, hq₂, pₜ, TL_support_subset hpₜ, hqpₜ, h⟩,
    },
    {
        rcases h with ⟨q, hq₁, hq₂, hpq, h⟩,
        refine ⟨q, hq₁, hq₂, p.LM, LM_mem_support hp, hpq, by rw ←h; refl⟩,
    }
end, begin
    revert r,
    apply induction p,
    {intros r hr, apply absurd hr zero_not_is_red_rel},
    {
        intros p ih r hr,
        rcases hr with ⟨q, hq₁, hq₂, pₜ, hpₜ, hqpₜ, h⟩,
        by_cases hpₜp : pₜ = p.LM,
        {
            apply red_one_step.red_LM (nez_of_mem_support hpₜ),
            refine ⟨q, hq₁, hq₂, by rwa ←hpₜp, by rw [h, hpₜp]; refl,⟩,
        },
        {
            have hp_LM : p.LM > (-(q * monomial (pₜ - LM q) (p pₜ / LC q))).LM,
            {
                simp [LM_of_mul_m, hq₂, div_ne_zero (mem_support_iff.1 hpₜ) (LC_nez_iff.1 hq₂), add_sub_cancel' hqpₜ],
                apply lt_of_le_of_ne (LM_rel' hpₜ) hpₜp
            },
            have hr : p.LT = r.LT := by simp [LT, h, LM_of_add_left hp_LM, LC_of_add_left hp_LM],

            apply red_one_step.cons (nez_of_mem_support hpₜ) (ih ⟨q, hq₁, hq₂, pₜ, mem_TL_support hpₜp hpₜ, hqpₜ, _⟩) hr,
            {
                rw [←@add_left_cancel_iff _ _ p.LT, ←add_sub_assoc, LM_TL_eq p, hr, LM_TL_eq r, TL_apply pₜ],
                simpa [ne.symm hpₜp] using h,
            },
        }
    }
end⟩

lemma is_red_rel_reducible {p r : mv_polynomial σ α} (h : is_red_rel S p r) : reducible S p :=
begin
    rcases h with ⟨q, hq₁, hq₂, pₜ, hpₜ, hqpₜ, _⟩,
    refine ⟨q, hq₁, hq₂, pₜ, hpₜ, hqpₜ⟩,
end

lemma reducible_is_red_rel {p : mv_polynomial σ α} (h : reducible S p) : ∃ r, is_red_rel S p r :=
begin
    rcases h with ⟨q, hq₁, hq₂, pₜ, hpₜ, hqpₜ⟩,
    refine ⟨p - q * monomial (pₜ - q.LM) (p pₜ / q.LC), q, hq₁, hq₂, pₜ, hpₜ, hqpₜ, rfl⟩,
end

lemma zero_red {r : mv_polynomial σ α} : (0 : mv_polynomial σ α) ↛[s] r  :=
λ h, zero_not_reducible (is_red_rel_reducible (by rwa red_one_step_is_red_rel at h))

lemma red_mem_S {q : mv_polynomial σ α} (hq₁ : q ∈ S) (hq₂ : q ≠ 0) : q →[S] 0 :=
begin
    rw red_one_step_is_red_rel,
    refine ⟨q, hq₁, hq₂, q.LM, LM_mem_support hq₂, by simp, _⟩,
    have h₁ : q q.LM = q.LC := rfl,
    have h₂ : (monomial 0 1 : mv_polynomial σ α) = C 1 := by simp [C],
    simp [h₁, div_self (LC_nez_iff.1 hq₂), h₂],
end

theorem red_plus_mul {p r : mv_polynomial σ α} (h : p →[S]+ r) :
    ∀ a b, (monomial a b * p) →[S]+ (monomial a b * r) :=
begin
    intros a b,
    by_cases hb : b = 0,
    {simp [hb], exact rtc.refl'},
    {
        revert a b,
        induction h with p p r h p q r hpq hqr ih₁ ih₂;
        intros a b hb,
        {exact rtc.refl'},
        {
            apply rtc.base',
            rw red_one_step_is_red_rel at h ⊢,
            rcases h with ⟨q, hq₁, hq₂, pₜ, hp, hpq, h⟩,
            refine ⟨q, hq₁, hq₂, a + pₜ, mul_mem_mul_support hb _ hp, dvd_of_dvd_of_add' hpq _,
                by rw [mul_apply hp, finsupp.add_sub_assoc' hpq, mul_div_assoc, ←monomial_mul_monomial,
                mul_left_comm, ←mul_sub, h]⟩,
        },
        {exact rtc.trans' (ih₁ a b hb) (ih₂ a b hb)}
    }
end

lemma red_plus_zero_of_mul {p : mv_polynomial σ α} (h : p →[S]+ 0) :
    ∀ a b, (monomial a b * p) →[S]+ 0 := by simpa using red_plus_mul h

lemma red_star_zero_of_mul {p : mv_polynomial σ α} (h : p →[S]* 0) :
    ∀ a b, (monomial a b * p) →[S]* 0 := λ a b, ⟨red_plus_zero_of_mul h.left a b, zero_irreducible⟩

lemma lt_of_red_one_step {p r : mv_polynomial σ α} (h : p →[S] r) : r < p :=
begin
    induction h with p r hp h₁ h₂ ih p r hp h,
    {apply lt.LM_eq hp h₂.symm ih},
    {
        rcases h with ⟨q, h₁, h₂, h₃, h₄⟩,
        rw ←h₄,
        by_cases hp' : p.LM = 0,
        {
            simp [hp'] at h₃,
            rw reduction_of_LM_eqz hp' h₃ h₂,
            apply lt.zero hp,
        },
        {apply lt.LM_lt (reduction_LM_lt h₃ hp' h₂)}
    }
end

lemma le_of_red_plus {p r : mv_polynomial σ α} (h : p →[S]+ r) : r < p ∨ r = p :=
begin
    induction h with _ _ _ h p q r hpq hqr ih₁ ih₂,
    {simp},
    {left, apply lt_of_red_one_step h},
    {
        cases ih₁; cases ih₂,
        {left, exact trans ih₂ ih₁},
        {left, rwa ih₂},
        {left, rwa ←ih₁},
        {right, rwa ih₂},
    }
end

lemma red_lt_of_le_of_lt {p q r : mv_polynomial σ α} (hpq : p →[S] q) (hqr : q →[S]+ r) : r < p :=
begin
    cases le_of_red_plus hqr,
    {exact trans h (lt_of_red_one_step hpq)},
    {simpa [h] using lt_of_red_one_step hpq}
end

lemma red_lt_of_le_of_lt' {p q r : mv_polynomial σ α} (hpq : p →[S] q) (hqr : q →[S]* r) : r < p :=
red_lt_of_le_of_lt hpq hqr.left

lemma red_one_step_LM_ge {p r : mv_polynomial σ α} (h : p →[S] r) : p.LM ≥ r.LM := LM_le_of_lt (lt_of_red_one_step h)
lemma red_plus_LM_ge {p r : mv_polynomial σ α} (h : p →[S]+ r) : p.LM ≥ r.LM :=
begin
    induction h with _ _ _ h _ _ _ _ _ ih₁ ih₂,
    {exact le_refl _},
    {exact red_one_step_LM_ge h},
    {exact ge_trans ih₁ ih₂},
end

lemma red_plus_irreducible {p q : mv_polynomial σ α} (hp : irreducible S p) (h : p →[S]+ q) : q = p :=
begin
    induction h with _ p q h p q r hpq hpr ih₁ ih₂,
    {refl},
    {apply absurd (is_red_rel_reducible (by rwa red_one_step_is_red_rel at h)) (by simpa using hp)},
    {simpa [ih₁ hp, hp] using ih₂},
end

theorem red_star_irreducible {p q : mv_polynomial σ α} (hp : irreducible S p) (h : p →[S]* q) : q = p :=
red_plus_irreducible hp h.left

lemma red_const {p r : mv_polynomial σ α} (hp : p.LM = 0) (h : p →[S] r) : r = 0 :=
begin
    cases h with _ _ _ h _ _ _ hp' h,
    {apply absurd (by rwa TL_eqz_of_LM_eqz hp at h) (zero_red _)},
    {
        rcases h with ⟨q, h₁, h₂, h₃, h₄⟩,
        simp [hp] at h₃,
        rw ←h₄,
        exact reduction_of_LM_eqz hp h₃ h₂,
    }
end

lemma red_plus_const {p r : mv_polynomial σ α} (hp : p.LM = 0) (h : p →[S]+ r) : p = r ∨ r = 0 :=
begin
    induction h with _ p r h p q r hpq hqr ih₁ ih₂,
    {simp},
    {simp [red_const hp h]},
    {
        cases ih₁ hp,
        {
            rw ←h at ih₂,
            exact ih₂ hp,
        },
        {
            right,
            conv at ih₂ in (_ ∨ _) {rw eq_comm},
            simpa [h] using ih₂,
        }
    }
end

lemma red_star_const {p r : mv_polynomial σ α} (hp : p.LM = 0) (h : p →[S]* r) : p = r ∨ r = 0 :=
red_plus_const hp h.left

lemma red_plus_trans {p r : mv_polynomial σ α} (h : p →[S]+ r) : p ≠ r → ∃ q, (p →[S] q) ∧ (q →[S]+ r) :=
begin
    induction h with _ p₂ r₂ h p₃ q₃ r₃ h₁ h₂ ih₁ ih₂,
    {simp},
    {intro, use [r₂, h, rtc.refl']},
    {
        by_cases p₃ = q₃,
        {rwa h},
        {
            intro,
            rcases ih₁ h with ⟨t, ht₁, ht₂⟩,
            use [t, ht₁, rtc.trans' ht₂ h₂],
        }
    }
end

lemma red_star_trans {p r : mv_polynomial σ α} (h : p →[S]* r) : reducible S p → ∃ q, (p →[S] q) ∧ (q →[S]* r) :=
λ hp, by simpa [h.right] using red_plus_trans h.left (λ hpr, ((irred_not_red S).1 h.right) (by rwa hpr at hp))

lemma exists_red_star (p : mv_polynomial σ α) : ∃ r, p →[s]* r :=
@well_founded.recursion (mv_polynomial σ α) (<) lt_wf _ p
(begin
    intros p ih,
    by_cases hp : irreducible s p,
    {use [p, rtc.refl', hp]},
    {
        cases reducible_is_red_rel (by rwa ←red_not_irred) with q hq,
        rw ←red_one_step_is_red_rel at hq,
        rcases ih q (lt_of_red_one_step hq) with ⟨r, hr₁, hr₂⟩,
        refine ⟨r, rtc.base_trans hq hr₁, hr₂⟩,
    }
end)

lemma exists_red_star_of_red {p q : mv_polynomial σ α} (h : p →[S] q) :
∃ r, (q →[S]* r) ∧ (p →[S]* r) :=
begin
    rcases exists_red_star S q with ⟨r, hr₁, hr₂⟩,
    refine ⟨r, ⟨hr₁, hr₂⟩, ⟨rtc.base_trans h hr₁, hr₂⟩⟩,
end

lemma exists_red_star_of_red_plus {p q : mv_polynomial σ α} (h : p →[S]+ q) :
∃ r, (q →[S]* r) ∧ (p →[S]* r) :=
begin
    induction h with p p q h p₃ q₃ r₃ hpq hqr ih₁ ih₂,
    {
        cases exists_red_star S p with r h,
        use [r, h, h],
    },
    {exact exists_red_star_of_red h},
    {
        rcases ih₂ with ⟨r, hr₁, ⟨hr₂, hr₃⟩⟩,
        use [r, hr₁, ⟨rtc.trans' hpq hr₂, hr₃⟩],
    }
end

lemma red_m_not_mem {p q r : mv_polynomial σ α} (hq : q ≠ 0) {pₜ} (hpₜ : pₜ ∈ p.support)
(hqpₜ : q.LM ∣ pₜ) (h : r = p - q * monomial (pₜ - q.LM) (p pₜ / q.LC)) : pₜ ∉ r.support :=
begin
    have h_LC : (q * monomial (pₜ - LM q) (p pₜ / LC q)) pₜ = (q * monomial (pₜ - LM q) (p pₜ / LC q)).LC,
        have h₁ : p pₜ / q q.LM ≠ 0 := div_ne_zero (by simpa using hpₜ) (LC_nez_iff.1 hq),
        simp [LC, LM_of_mul_m, hq, h₁, finsupp.add_sub_cancel' hqpₜ], refl,
    simp [h, h_LC, LC_of_mul_m, mul_div_cancel' _ (LC_nez_iff.1 hq)],
end

lemma sub_red_comp {p r : mv_polynomial σ α} (h : p →[S] r) :
∀ u, ∃ t₁ t₂, (p + u →[S]+ t₁) ∧ (u →[S]+ t₂) ∧ (r = t₁ - t₂) :=
λ u, begin
    rcases red_one_step_is_red_rel.1 h with ⟨q, hq₁, hq₂, pₜ, hpₜ, hqpₜ, h⟩,
    have hr := red_m_not_mem hq₂ hpₜ hqpₜ h,
    by_cases hpₜu : pₜ ∈ u.support;
    simp at hpₜu hr hpₜ,
    {
        by_cases hpₜ': pₜ ∈ (p + u).support,
        {
            refine ⟨p + u - q * monomial (pₜ - LM q) ((p + u) pₜ / LC q),
                u - q * monomial (pₜ - LM q) (u pₜ / LC q),
                rtc.base' (red_one_step_is_red_rel.2 ⟨q, hq₁, hq₂, pₜ, hpₜ', hqpₜ, rfl⟩),
                rtc.base' (red_one_step_is_red_rel.2 ⟨q, hq₁, hq₂, pₜ, by simpa using hpₜu, hqpₜ, rfl⟩), _⟩,
            {
                simp [-mul_neg_eq_neg_mul_symm, neg_mul_eq_mul_neg],
                rw [←mul_add, ←monomial_neg, ←neg_div, ←monomial_add_monomial,
                div_add_div_same, neg_add_rev, ←add_assoc],
                simp [neg_div, h],
            }
        },
        {
            simp [add_eq_zero_iff_neg_eq] at hpₜ',
            refine ⟨p + u, u - q * monomial (pₜ - LM q) (u pₜ / LC q), rtc.refl',
                rtc.base' (red_one_step_is_red_rel.2 ⟨q, hq₁, hq₂, pₜ, by simpa using hpₜu, hqpₜ, rfl⟩),
                by simp [hpₜ'.symm, neg_div, h]⟩,
        }
    },
    {
        refine ⟨p + u - q * monomial (pₜ - q.LM) ((p + u) pₜ/ q.LC), u,
            rtc.base' (red_one_step_is_red_rel.2 ⟨q, hq₁, hq₂, pₜ, by simpa [hpₜu] using hpₜ, hqpₜ, rfl⟩),
            rtc.refl', by simp [hpₜu, h]⟩,
    }
end

lemma sub_red_plus_comp {p r : mv_polynomial σ α} (h : p →[S]+ r) :
∀ u, ∃ t, (p + u →[S]+ r + t) ∧ (u →[S]+ t) :=
begin
    induction h with r p r h p q r hpq hqr ih₁ ih₂;
    intros u,
    {refine ⟨u, rtc.refl', rtc.refl'⟩},
    {
        rcases sub_red_comp h u with ⟨t₁, t₂, h₁, h₂, h₃⟩,
        refine ⟨t₂, by rwa eq_sub_iff_add_eq.1 h₃, h₂⟩,
    },
    {
        rcases ih₁ u with ⟨t₁, hput₁, hut₁⟩,
        rcases ih₂ t₁ with ⟨t₂, hqut₂, hut₂⟩,
        refine ⟨t₂, rtc.trans' hput₁ hqut₂, rtc.trans' hut₁ hut₂⟩,
    }
end

lemma sub_red_star_zero {p q : mv_polynomial σ α} (h : p - q →[S]* 0) :
∃ t, (p →[S]* t) ∧ (q →[S]* t) :=
begin
    rcases sub_red_plus_comp h.left q with ⟨r, hpr, hqr⟩,
    rcases exists_red_star S r with ⟨t, ht₁, ht₂⟩,
    refine ⟨t, ⟨rtc.trans' (by simpa using hpr) ht₁, ht₂⟩, ⟨rtc.trans' hqr ht₁, ht₂⟩⟩,
end

lemma red_add_of_red {p r : mv_polynomial σ α} (h : p →[S] r) :
∀ u, ∃ t, (p + u →[S]+ t) ∧ (r + u →[S]+ t) :=
λ u, begin
    rcases red_one_step_is_red_rel.1 h with ⟨q, hq₁, hq₂, pₜ, hpₜ, hqpₜ, h⟩,
    have hr := red_m_not_mem hq₂ hpₜ hqpₜ h,
    by_cases hpₜu : pₜ ∈ u.support;
    simp at hpₜu hr,
    {
        by_cases hpₜ': pₜ ∈ (p + u).support,
        {
            refine ⟨r + u - q * monomial (pₜ - LM q) (u pₜ / LC q), _, _⟩;
            apply rtc.base'; rw [red_one_step_is_red_rel],
            {
                conv at h {
                    rw [←@add_right_cancel_iff _ _ (u - q * monomial (pₜ - q.LM) (u pₜ / q.LC)), ←add_sub_assoc],
                    to_rhs, rw [←add_sub_assoc, sub_add_eq_add_sub, sub_sub, ←mul_add, ←monomial_add_monomial, div_add_div_same, ←add_apply],
                },
                refine ⟨q, hq₁, hq₂, pₜ, hpₜ', hqpₜ, by rw h⟩,
            },
            {refine ⟨q, hq₁, hq₂, pₜ, by simpa [hr] using hpₜu, hqpₜ, by conv in ((r + u) pₜ) {simp [hr]},⟩}
        },
        {
            refine ⟨p + u, rtc.refl', _⟩,
            apply rtc.base',
            rw red_one_step_is_red_rel,
            refine ⟨q, hq₁, hq₂, pₜ, by simpa [hr] using hpₜu, hqpₜ, _⟩,
            simp [add_eq_zero_iff_eq_neg] at hpₜ',
            simp [h, hpₜ', neg_div, hr],
        }
    },
    {
        refine ⟨r + u, _, rtc.refl'⟩,
        apply rtc.base',
        rw [red_one_step_is_red_rel, h, sub_add_eq_add_sub],
        refine ⟨q, hq₁, hq₂, pₜ, by simpa [hpₜu] using hpₜ, hqpₜ, by simp [hpₜu]⟩,
    }
end

lemma red_of_TL_red {p r : mv_polynomial σ α} (h : p.TL →[S] r) :
p →[S] p.LT + r :=
begin
    by_cases hp : p.LM = 0,
    {
        rw [TL_eqz_of_LM_eqz hp] at h,
        apply absurd h (zero_red _),
    },
    {
        have hpr := gt_of_gt_of_ge (gt_TL_LM_of_LM_nez hp) (red_one_step_LM_ge h),
        apply red_one_step.cons (nez_of_LM_nez hp) (by rwa ←TL_of_add_gt_LM hpr (LC_nez_of_LM_nez hp) at h),
        simp [LT_of_add_right (by rwa eq_LM_of_monomial p.LM (LC_nez_of_LM_nez hp) at hpr)], refl,
    }
end

lemma red_plus_TL_plus {p r : mv_polynomial σ α} (h : p.TL →[S]+ r) :
p →[S]+ p.LT + r :=
begin
    conv in p {rw ←LM_TL_eq p},
    by_cases hp : p.LM = 0,
    {
        rw [TL_eqz_of_LM_eqz hp] at h ⊢,
        have hr : r = 0,
            by_contradiction hr,
            rcases red_plus_trans h (ne.symm hr) with ⟨_, hq, _⟩,
            exact (zero_red _) hq,
        simpa [hr] using rtc.refl',
    },
    {
        have := gt_TL_LM_of_LM_nez hp, revert this,
        induction h with _ p' r' h p' q' r' hpq hqr ih₁ ih₂;
        intro hp',
        {exact rtc.refl'},
        {
            have := red_of_TL_red (by rwa ←TL_of_add_gt_LM hp' (LC_nez_of_LM_nez hp) at h),
            rw LT_of_add_gt_LM hp' (LC_nez_of_LM_nez hp) at this,
            apply rtc.base' this,
        },
        {exact rtc.trans' (ih₁ hp') (ih₂ (lt_of_le_of_lt (red_plus_LM_ge hpq) hp'))}
    }
end

lemma red_plus_TL_star {p r : mv_polynomial σ α} (h : p.TL →[S]* r) :
p →[S]+ p.LT + r := red_plus_TL_plus h.left

lemma LM_eq_lt_of_lt_TL {p q : mv_polynomial σ α} (h : q < p.TL) :  p.LT + q < p :=
begin
    by_cases hp₁ : p.LM = 0,
    {
        simp [TL_eqz_of_LM_eqz hp₁] at h,
        apply absurd h not_lt_zero,
    },
    {
        have hp₂ := nez_of_LM_nez hp₁,
        have hp₃ := LC_nez_iff.1 hp₂,
        have hq : p.LM > q.LM := lt_of_le_of_lt (LM_le_of_lt h) (gt_TL_LM_of_LM_nez hp₁),
        apply lt.LM_eq hp₂,
        {
            conv at hq in p.LM {rw ←LM_of_LT},
            rw LT_of_add_left hq,
            conv in (p.LT.LT) {rw LT, simp},
            refl,
        },
        {rwa [LT, TL_of_add_gt_LM hq hp₃]},
    }
end

lemma red_cons_reduction {p r : mv_polynomial σ α} (hpq₁ : p.TL →[S] r.TL) (hpq₂ : p.LT = r.LT) :
∀ q, ∃ u, (reduction p q →[S]* u) ∧ (reduction r q →[S]* u) :=
λ q, begin
    have hpr : (p →[S] r) := by simpa [hpq₂, LM_TL_eq r] using red_of_TL_red hpq₁,
    rcases red_add_of_red hpr (-q * monomial (p.LM - q.LM) (p.LC/q.LC)) with ⟨u, hpu, hru⟩,
    rcases exists_red_star S u with ⟨u', hu'₁, hu'₂⟩,
    refine ⟨u', ⟨rtc.trans' (by simpa [reduction] using hpu) hu'₁, hu'₂⟩,
    ⟨rtc.trans' (by simpa [reduction, LM_eq_of_LT_eq hpq₂, LC_eq_of_LT_eq hpq₂] using hru) hu'₁, hu'₂⟩⟩,
end

theorem red_confluent (h : ∀ {p q} (hp : p ∈ S) (hq : q ∈ S), s_poly p q →[S]* 0)
(p : mv_polynomial σ α) : ∀ {r t}, (p →[S]* r) → (p →[S]* t) → r = t :=
well_founded.recursion lt_wf p begin
    intros p ih r t hpr hpt,
    by_cases hp₁ : irreducible S p,
    {simp [red_star_irreducible hp₁ hpr, red_star_irreducible hp₁ hpt]},
    {
        by_cases hp₂ : p.LM = 0,
        {
            cases red_star_const hp₂ hpr,
            {
                rw h_1 at hp₁,
                cases hpr with _ hpr,
                apply absurd hpr hp₁,
            },
            {
                cases red_star_const hp₂ hpt,
                {
                    rw h_2 at hp₁,
                    cases hpt with _ hpt,
                    apply absurd hpt hp₁,
                },
                {rw [h_1, h_2]}
            }
        },
        {
            rcases red_star_trans hpr (by simpa using hp₁) with ⟨q₁, hpq₁, hq₁r⟩,
            rcases red_star_trans hpt (by simpa using hp₁) with ⟨q₂, hpq₂, hq₂t⟩,
            have hpq₁_lt := lt_of_red_one_step hpq₁,
            have hpq₂_lt := lt_of_red_one_step hpq₂,
            cases hqr : hpq₁ with a b hp₃ hpq₁₁ hpq₁₂ _ _ hp₃ hr_pq₁;
            cases hqt : hpq₂ with _ _ hp₃ hpq₂₁ hpq₂₂ _ _ hp₃ hr_pq₂;
            clear hp₃ hqr hqt _x _x_1,
            {
                rcases exists_red_star_of_red hpq₁₁ with ⟨r'₁, hqr'₁, hpr'₁⟩,
                rcases exists_red_star_of_red hpq₂₁ with ⟨t'₁, hqt'₁, hpt'₁⟩,
                have hrt₁: r'₁ = t'₁ := ih _ (TL_lt hp₃) hpr'₁ hpt'₁,
                rcases exists_red_star_of_red_plus (red_plus_TL_star hqr'₁) with ⟨r'₂, hqr'₁₂, hqr'₂⟩,
                rcases exists_red_star_of_red_plus (red_plus_TL_star hqt'₁) with ⟨t'₂, hqt'₁₂, hqt'₂⟩,
                have hrt₂: r'₂ = t'₂ := ih (p.LT + t'₁) (LM_eq_lt_of_lt_TL (red_lt_of_le_of_lt' hpq₂₁ hqt'₁))
                    (by simpa [hrt₁, hpq₁₂] using hqr'₁₂) (by simpa [hpq₂₂] using hqt'₁₂),
                simpa [ih _ hpq₁_lt hq₁r hqr'₂, ih _ hpq₂_lt hq₂t hqt'₂] using hrt₂,
            },
            {
                rcases hr_pq₂ with ⟨q, h₁, h₂, h₃, h₄⟩,
                rcases red_cons_reduction hpq₁₁ hpq₁₂ q with ⟨u, hq₂u, hq₁u⟩, rw h₄ at hq₂u,
                have hq₁u' : (q₁ →[S]* u) :=
                    ⟨rtc.base_trans
                        (red_one_step.red_LM (nez_of_LM_nez (by rwa [←LM_eq_of_LT_eq hpq₁₂])) ⟨q, h₁, h₂, by rwa ←LM_eq_of_LT_eq hpq₁₂, rfl⟩)
                        hq₁u.left, hq₁u.right⟩,
                simp [ih _ hpq₁_lt hq₁r hq₁u', ih _ hpq₂_lt hq₂t hq₂u],
            },
            {
                rcases hr_pq₁ with ⟨q, h₁, h₂, h₃, h₄⟩,
                rcases red_cons_reduction hpq₂₁ hpq₂₂ q with ⟨u, hq₁u, hq₂u⟩, rw h₄ at hq₁u,
                have hq₂u' : (q₂ →[S]* u) :=
                    ⟨rtc.base_trans
                        (red_one_step.red_LM (nez_of_LM_nez (by rwa [←LM_eq_of_LT_eq hpq₂₂])) ⟨q, h₁, h₂, by rwa ←LM_eq_of_LT_eq hpq₂₂, rfl⟩)
                        hq₂u.left, hq₂u.right⟩,
                simp [ih _ hpq₁_lt hq₁r hq₁u, ih _ hpq₂_lt hq₂t hq₂u'],
            },
            {
                rcases hr_pq₁ with ⟨q₁', hq₁₁, hq₁₂, hq₁₃, hq₁₄⟩,
                rcases hr_pq₂ with ⟨q₂', hq₂₁, hq₂₂, hq₂₃, hq₂₄⟩,
                cases exists_eq_mul_left_of_dvd (lcm_dvd hq₁₃ hq₂₃) with m hq₃,
                have hq : ((q₁ - q₂) →[S]* 0),
                {
                    have h_s : s_poly q₂' q₁' =
                        (q₂' * monomial (m_lcm q₁'.LM q₂'.LM - q₂'.LM) q₂'.LC⁻¹) + -(q₁' * monomial (m_lcm q₁'.LM q₂'.LM - q₁'.LM) q₁'.LC⁻¹),
                        simp [s_poly, mul_comm, m_lcm_comm q₁'.LM q₂'.LM],
                    simp [hq₁₄.symm, hq₂₄.symm, reduction, hq₃,
                    add_sub_assoc', finsupp.dvd_lcm_right, finsupp.dvd_lcm_left,
                    div_eq_mul_one_div p.LC, monomial_mul_monomial.symm,
                    mul_left_comm _ (monomial m p.LC)],
                    rw [neg_mul_eq_mul_neg, ←mul_add, ←h_s],
                    refine ⟨red_plus_zero_of_mul (h hq₂₁ hq₁₁).left _ _, zero_not_reducible⟩,
                },
                rcases sub_red_star_zero hq with ⟨u, hq₁u, hq₂u⟩,
                simp [ih _ hpq₁_lt hq₁r hq₁u, ih _ hpq₂_lt hq₂t hq₂u],
            }
        }
    }
end

lemma red_plus_insert {p r : mv_polynomial σ α} (h : p →[S]+ r) : ∀ a, p →[insert a S]+ r :=
begin
    induction h with _ p r h p q r hpq hqr ih₁ ih₂;
    intro a,
    {exact rtc.refl'},
    {
        apply rtc.base',
        rw red_one_step_is_red_rel at h ⊢,
        rcases h with ⟨q, hq₁, hq₂, pₜ, hpₜ, hqpₜ, h⟩,
        refine ⟨q, by simp [hq₁], hq₂, pₜ, hpₜ, hqpₜ, h⟩,
    },
    {exact rtc.trans' (ih₁ a) (ih₂ a)}
end

end reduction

section step
inductive buchstep : (list (mv_polynomial σ α) × list (mv_polynomial σ α) × list (mv_polynomial σ α))
→ (list (mv_polynomial σ α) × list (mv_polynomial σ α) × list (mv_polynomial σ α)) → Prop
| zero {p} : ∀ l₁ l₂ l₃, red_list p l₁ = 0 → buchstep ⟨l₁, p :: l₂, l₃⟩ ⟨l₁, l₂, l₃⟩
| non_zero {p} : ∀ l₁ l₂ l₃, red_list p l₁ ≠ 0 →
    buchstep ⟨l₁, p :: l₂, l₃⟩
        ⟨(red_list p l₁) :: l₁, s_polyL (red_list p l₁) l₁ ++ l₂, s_polyL (red_list p l₁) l₁ ++ l₃⟩

def buchstep_plus : (list (mv_polynomial σ α) × list (mv_polynomial σ α) × list (mv_polynomial σ α))
→ (list (mv_polynomial σ α) × list (mv_polynomial σ α) × list (mv_polynomial σ α)) → Prop := rtc buchstep

lemma buchstep.zero' {p : mv_polynomial σ α} {l₁ l₂ l₃} (h : red_list p l₁ = 0) :
buchstep ⟨l₁, p :: l₂, l₃⟩ ⟨l₁, l₂, l₃⟩ := buchstep.zero l₁ l₂ l₃ h

lemma buchstep.non_zero' {p : mv_polynomial σ α} {l₁ l₂ l₃} (h : red_list p l₁ ≠ 0) :
buchstep ⟨l₁, p :: l₂, l₃⟩ ⟨(red_list p l₁) :: l₁,
    s_polyL (red_list p l₁) l₁ ++ l₂, s_polyL (red_list p l₁) l₁ ++ l₃⟩ := buchstep.non_zero l₁ l₂ l₃ h

lemma red_list_aux_red_plus_aux : ∀ (p : mv_polynomial σ α) {l₁ l₂ : list (mv_polynomial σ α)},
l₂ ⊆ l₁ → (p →[l₁.to_finset]+ red_list_aux p l₂)
| p l₁ [] := by simp [red_list_aux]; exact rtc.refl'
| p l₁ (q :: l₂) := λ h, begin
    by_cases hp : p = 0,
    {simp [hp, zero_red_list_aux], exact rtc.refl'},
    {
        by_cases hqp : q.LM ∣ p.LM; simp [red_list_aux, hqp] at h ⊢,
        {
            by_cases hq : q = 0,
            {
                simp [reduction, hq],
                apply red_list_aux_red_plus_aux _ h.right,
            },
            {
                apply rtc.base_trans (red_one_step.red_LM hp ⟨q, by simp [h.left], hq, hqp, rfl⟩)
                (red_list_aux_red_plus_aux (reduction p q) h.right),
            }
        },
        {apply red_list_aux_red_plus_aux _ h.right}
    }
end

lemma red_list_aux_red_plus (p : mv_polynomial σ α) (l : list (mv_polynomial σ α)) :
(p →[l.to_finset]+ red_list_aux p l) := red_list_aux_red_plus_aux p (by simp)

lemma red_list_red_plus : ∀ (p : mv_polynomial σ α) (l : list (mv_polynomial σ α)),
(p →[l.to_finset]+ red_list p l)
| p l := begin
    unfold red_list, simp,
    by_cases hp₁ : red_list_aux p l = p; simp [hp₁],
    {exact rtc.refl'},
    {
        by_cases hp₂ : p.LM = 0; simp [hp₂],
        {
            have h := red_plus_const hp₂ (red_list_aux_red_plus p l),
            simp [ne.symm hp₁] at h,
            simpa [h] using red_list_aux_red_plus p l,
        },
        {
            let : (red_list_aux p l).LM < p.LM, from red_list_aux_LM_lt l p hp₂ hp₁,
            apply rtc.trans' (red_list_aux_red_plus p l) (red_list_red_plus _ l),
        }
    }
end
using_well_founded
{ rel_tac := λ _ _, `[exact ⟨_, inv_image.wf (λ a, a.1.LM) _inst_6.wf⟩]
, dec_tac := tactic.assumption }

set_option class.instance_max_depth 50
lemma buchberger_buchplus : ∀ L : list (mv_polynomial σ α) × list (mv_polynomial σ α),
buchstep_plus ⟨L.1, L.2, s_polys L.1⟩ ⟨buchberger ⟨L.1, L.2⟩, [], s_polys (buchberger ⟨L.1, L.2⟩)⟩
| ⟨l₁, []⟩ := by unfold buchberger; simp; apply rtc.refl'
| ⟨l₁, (p :: l₂)⟩ :=
let lex := prod.lex ((>) : ideal (mv_polynomial σ α) → ideal (mv_polynomial σ α) → Prop) nat.lt in
begin
    unfold buchberger,
    by_cases red_list p l₁ = 0; simp [h],
    {
        let : lex ⟨monomial_ideal l₁, l₂.length⟩ ⟨monomial_ideal l₁, (list.cons p l₂).length⟩ :=
            by right; rw [list.length_cons]; apply nat.lt_succ_self,
        apply rtc.base_trans (buchstep.zero' h) (buchberger_buchplus ⟨l₁, l₂⟩),
    },
    {
        let : lex ⟨monomial_ideal (list.cons (red_list p l₁) l₁), (s_polyL (red_list p l₁) l₁ ++ l₂).length⟩
            ⟨monomial_ideal l₁, (list.cons p l₂).length⟩ :=
            by left; exact ideal_increase l₁ p h,
        apply rtc.base_trans (buchstep.non_zero' h)
            (buchberger_buchplus ⟨red_list p l₁ :: l₁, s_polyL (red_list p l₁) l₁ ++ l₂⟩)
    }
end
using_well_founded
{ rel_tac := λ _ _,
`[exact ⟨_, inv_image.wf (λ ⟨l₁, l₂⟩, prod.mk (monomial_ideal l₁) l₂.length) (prod.lex_wf ideal_wf nat.lt_wf)⟩ ]
, dec_tac := tactic.assumption }

lemma buchstep_subset_or_red_eqz (L₁ L₂ : list (mv_polynomial σ α) × list (mv_polynomial σ α) × list (mv_polynomial σ α))
(h : buchstep_plus L₁ L₂) : (∀ a ∈ L₁.2.2, a ∈ L₁.2.1 ∨ (a →[L₁.1.to_finset]+ 0)) →
∀ a ∈ L₂.2.2, a ∈ L₂.2.1 ∨ (a →[L₂.1.to_finset]+ 0) :=
begin
    induction h with _ L₁ L₂ h L₁ L₂ L₃ h₁ h₂ ih₁ ih₂,
    {simp},
    {
        cases h with p l₁ l₂ l₃ hp p l₁ l₂ l₃ hp,
        {
            simp_intros H a ha,
            rcases H a ha with ⟨h₁ | h₂⟩ | h₃,
            {right, simpa [hp, h₁] using red_list_red_plus p l₁},
            {left, exact h₂},
            {right, exact h₃},
        },
        {
            simp_intros H a' ha',
            cases ha',
            {simp [ha']},
            {
                rcases H a' ha' with ⟨h₁ | h₂⟩ | h₃,
                {
                    right, rw h₁,
                    apply rtc.trans_base (red_plus_insert (red_list_red_plus p l₁) (red_list p l₁)),
                    apply red_mem_S (finset.mem_insert_self _ _) hp,
                },
                {simp [h₂]},
                {
                    right,
                    apply red_plus_insert h₃,
                }
            }
        }
    },
    {
        simp_intros H,
        exact ih₂ (ih₁ H),
    }
end

lemma s_poly_mem_s_polys : ∀ (l₁ l₂ : list (mv_polynomial σ α)),
(∀ x : mv_polynomial σ α, x ∈ s_polys l₁ → (x →[l₂.to_finset]* 0))
→ ∀ (p q : mv_polynomial σ α), p ∈ l₁ → q ∈ l₁ → (s_poly p q →[l₂.to_finset]* 0)
| [] := by simp
| (hd :: tl) := λ l₂ h p q hp hq, begin
    cases hp; cases hq,
    {
        simp [hp, hq, s_poly],
        refine ⟨rtc.refl', zero_not_reducible⟩,
    },
    {
        apply h,
        simp [hp, s_polys, mem_s_polyL hq],
    },
    {
        rw s_poly_comm,
        have H : (monomial 0 1 : mv_polynomial σ α) = C 1 := by simp [C],
        simpa [H] using
            red_star_zero_of_mul (h (s_poly q p) (by simp [s_polys, hq, mem_s_polyL hp])) 0 (-1),
    },
    {
        apply s_poly_mem_s_polys tl _
            (λ x hx, h x (by simp [s_polys, hx])) p q hp hq,
    }
end

lemma buch_confluent_aux (l : list (mv_polynomial σ α)) :
∀ (p q ∈ buchberger ⟨l, s_polys l⟩), (s_poly p q →[(buchberger ⟨l, s_polys l⟩).to_finset]* 0) :=
begin
    apply s_poly_mem_s_polys,
    simp [zero_not_reducible],
    have := buchstep_subset_or_red_eqz ⟨l, s_polys l, s_polys l⟩
        ⟨buchberger ⟨l, s_polys l⟩, [], s_polys (buchberger ⟨l, s_polys l⟩)⟩ (buchberger_buchplus ⟨l, s_polys l⟩),
    simp at this,
    apply this,
    finish,
end

theorem buch_confluent (l : list (mv_polynomial σ α)) (p : mv_polynomial σ α) :
∀ {r t}, (p →[(buchberger ⟨l, s_polys l⟩).to_finset]* r) → (p →[(buchberger ⟨l, s_polys l⟩).to_finset]* t) → r = t :=
begin
    apply red_confluent,
    intros p q hp hq,
    apply buch_confluent_aux l p q (by simpa using hp) (by simpa using hq),
end

end step

end buch


import ring_theory.int.basic

lemma units_int.values (u: units ℤ): u = 1 ∨ u = -1 :=
begin
  have p₁ := fintype.complete u,
  cases p₁,
  left, exact p₁,
  cases p₁,
  right, exact p₁,
  exfalso, exact list.not_mem_nil u p₁,
end


import AutograderTests.Util

theorem imp_self : p → p :=
  sorry_in_exercise_else by intros; assumption


import for_mathlib.abelian_category
import for_mathlib.exact_seq3

noncomputable theory

open category_theory category_theory.limits

namespace category_theory
namespace exact

variables {𝓐 : Type*} [category 𝓐] [abelian 𝓐]
variables {A B C T : 𝓐} {f : A ⟶ B} {g : B ⟶ C}

section lift

variables (h : exact f g) [mono f] (φ : T ⟶ B) (w : φ ≫ g = 0)
include h w

def mono_lift : T ⟶ A :=
(abelian.is_limit_of_exact_of_mono f g h).lift (kernel_fork.of_ι _ w)

@[simp, reassoc] lemma mono_lift_comp : h.mono_lift φ w ≫ f = φ :=
(abelian.is_limit_of_exact_of_mono f g h).fac (kernel_fork.of_ι _ w) walking_parallel_pair.zero

lemma mono_lift_unique (e : T ⟶ A) (he : e ≫ f = φ) : e = h.mono_lift φ w :=
by rw [← cancel_mono f, he, h.mono_lift_comp]

end lift

section desc

variables (h : exact f g) [category_theory.epi g] (φ : B ⟶ T) (w : f ≫ φ = 0)
include h w

def epi_desc : C ⟶ T :=
(abelian.is_colimit_of_exact_of_epi f g h).desc (cokernel_cofork.of_π _ w)

@[simp, reassoc] lemma comp_epi_desc : g ≫ h.epi_desc φ w = φ :=
(abelian.is_colimit_of_exact_of_epi f g h).fac (cokernel_cofork.of_π _ w) walking_parallel_pair.one

lemma epi_desc_unique (e : C ⟶ T) (he : g ≫ e = φ) : e = h.epi_desc φ w :=
by rw [← cancel_epi g, he, h.comp_epi_desc]

end desc

end exact
end category_theory


namespace melting_point.geometry

universe u

class is_euclidian (S : Type u) :=
(B : S → S → S → Prop)
(cong : S × S → S × S → Prop)
-- Tarski axioms
(cong_refl (x y : S) : cong (x, y) (y, x))
(cong_trans (a b c : S × S) : cong a b → cong a c → cong b c)
(identity_of_congruence (x y z : S) : cong (x, y) (z, z) → x = y)
(segment_construction (x y a b : S) :
  ∃ z, B x y z ∧ cong (y, z) (a, b))
(five_segment (x y z x' y' z' u u' : S) :
  x ≠ y → B x y z → B x' y' z' →
  cong (x, y) (x', y') →
  cong (y, z) (y', z') →
  cong (x, u) (x', u') →
  cong (y, u) (y', u') →
  cong (z, u) (z', u'))
(identity_of_betweenness (x y : S) : B x y x → x = y)
(axiom_of_Pasch (x y z u v : S) :
  B x y z → B y v z → ∃ a, B u a y ∧ B v a x)
(lower_dimension (a b c : S) :
  ¬B a b c ∧ ¬B b c a ∧ ¬B c a b)
(upper_dimension (x y z u v : S) :
  cong (x, u) (x, v) →
  cong (y, u) (y, v) →
  cong (z, u) (z, v) →
  u ≠ v → B x y z ∧ B y z x ∧ B z x y)
(axiom_of_Euclid (x y z u v : S) :
  B x u v → B y u z → x ≠ y →
  ∃ a b, B x y a ∧ B x z b ∧ B a v b)
(axiom_schema_of_Continuity (φ ψ : S → Prop) :
  (∃ a, ∀ x y, φ x → ψ y → B a x y) →
  (∃ b, ∀ x y, φ x → ψ y → B x b y))
open is_euclidian

infix ` ≅ `:50 := is_euclidian.cong

section
  variables {S : Type u} [is_euclidian S]

  instance : has_mem S (S × S) :=
  ⟨λ x a, B a.fst x a.snd⟩

  def segment (x y : S) :=
  { z | B x z y }

  def line (x y : S) :=
  { z | B y x z ∨ B x y z ∨ B x z y }

  def circle (radius : S × S) :=
  { z | (radius.fst, z) ≅ radius }

  def disk (radius : S × S) : set S :=
  { z | ∃ (a : S × S), a.fst = radius.fst ∧ a ≅ radius ∧ z ∈ a }

  def triangle (a b c : S) :=
  { z | B a z c ∨ B a z b ∨ B b z c }

  def ray (a b : S) :=
  { c | B a c b ∨ B a b c }

  def angle (a b c : S) : set S :=
  { z | z ∈ ray b a ∨ z ∈ ray b c }

  def parallel (a b : set S) :=
  ¬∃ (z : S), z ∈ a ∧ z ∈ b

  def segment.is_sum (r₁ r₂ r : S × S) :=
  ∃ z, (r.fst, z) ≅ r₁ ∧ (r.snd, z) ≅ r₂ ∧ B r.fst z r.snd

  def circle.touch_externally (r₁ r₂ : S × S) :=
  ∃! (z : S), z ∈ circle r₁ ∧ z ∈ circle r₂ ∧ B r₁.fst z r₂.fst

  theorem sum_of_radiuses_tang_circles
    (r₁ r₂ : S × S) (h : circle.touch_externally r₁ r₂) :
    segment.is_sum r₁ r₂ (r₁.fst, r₂.fst) := begin
    cases h with z cond,
    cases cond with cond trash, clear trash,
    cases cond with belongs₁ cond,
    cases cond with belongs₂ H,
    existsi z, repeat { try { split }, assumption }
  end
end

end melting_point.geometry


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison
-/
import algebra.category.Module.epi_mono
import algebra.module.projective
import category_theory.preadditive.projective
import linear_algebra.finsupp_vector_space

/-!
# The category of `R`-modules has enough projectives.
-/

universes v u

open category_theory
open category_theory.limits
open linear_map

open_locale Module

/-- The categorical notion of projective object agrees with the explicit module-theoretic notion. -/
theorem is_projective.iff_projective {R : Type u} [ring R]
  {P : Type (max u v)} [add_comm_group P] [module R P] :
  module.projective R P ↔ projective (Module.of R P) :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { letI : module.projective R ↥(Module.of R P) := h,
    exact ⟨λ E X f e epi, module.projective_lifting_property _ _
      ((Module.epi_iff_surjective _).mp epi)⟩ },
  { refine module.projective_of_lifting_property _,
    introsI E X mE mX sE sX f g s,
    haveI : epi ↟f := (Module.epi_iff_surjective ↟f).mpr s,
    letI : projective (Module.of R P) := h,
    exact ⟨projective.factor_thru ↟g ↟f, projective.factor_thru_comp ↟g ↟f⟩ }
end

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

/-- Modules that have a basis are projective. -/
-- We transport the corresponding result from `module.projective`.
lemma projective_of_free {ι : Type*} (b : basis ι R M) : projective M :=
projective.of_iso (Module.of_self_iso _)
  ((is_projective.iff_projective).mp (module.projective_of_basis b))

/-- The category of modules has enough projectives, since every module is a quotient of a free
    module. -/
instance Module_enough_projectives : enough_projectives (Module.{max u v} R) :=
{ presentation :=
  λ M,
  ⟨{ P := Module.of R (M →₀ R),
    projective := projective_of_free finsupp.basis_single_one,
    f := finsupp.basis_single_one.constr ℕ id,
    epi := (epi_iff_range_eq_top _).mpr
      (range_eq_top.2 (λ m, ⟨finsupp.single m (1 : R), by simp [basis.constr]⟩)) }⟩, }

end Module


import Hw9
import Sets.Basic
import Lean.Elab.Print
import Lean.Elab.Command

open Set

variable (α β : Type)
variable (X Y Z : Set α)
variable (W : Set β)

theorem desiredType1 : ∅ ∈ 𝒫  X := sorry

theorem desiredType2 (U : β → Set α) : ∀ b, U b ⊆ BigUnion U := sorry

theorem desiredType3 (h : X ⊆ Y) : (X ×ˢ W) ⊆ (Y ×ˢ W) := sorry

theorem desiredType4 (h : Y ∩ Z = ∅) : Yᶜ ∪ Zᶜ = Univ := sorry

theorem desiredType5 : (X \ Y) ∪ (Y \ X) = (X ∪ Y) \ (X ∩ Y) := sorry

open Lean
open Lean.Meta
open Lean.Elab.Command

def n : String := "4"

def problem : String := "problem"++n

def desired : String := "desiredType"++n

def collectAxiomsOf (constName : Name) : MetaM (List String) := do
  let env ← getEnv
  let (_, s) := ((CollectAxioms.collect constName).run env).run {}
  let a := s.axioms.toList.map toString
  return a

#eval isDefEq (Expr.const desired []) (Expr.const problem [])
#eval collectAxiomsOf problem


/-
Copyright (c) 2018 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import Std.Data.AssocList
import Std.Data.Nat.Basic
import Std.Classes.BEq

namespace Std.HashMap

/-- A hash is lawful if elements which compare equal under `==` have equal hash. -/
class LawfulHashable (α : Type _) [BEq α] [Hashable α] : Prop where
  /-- Two elements which compare equal under the `BEq` instance have equal hash. -/
  hash_eq {a b : α} : a == b → hash a = hash b

namespace Imp

/--
The bucket array of a `HashMap` is a nonempty array of `AssocList`s.
(This type is an internal implementation detail of `HashMap`.)
-/
def Bucket (α : Type u) (β : Type v) := {b : Array (AssocList α β) // 0 < b.size}

namespace Bucket

/-- Construct a new empty bucket array with the specified capacity. -/
def mk (buckets := 8) (h : 0 < buckets := by decide) : Bucket α β :=
  ⟨mkArray buckets .nil, by simp [h]⟩

/-- Update one bucket in the bucket array with a new value. -/
def update (data : Bucket α β) (i : USize)
    (d : AssocList α β) (h : i.toNat < data.1.size) : Bucket α β :=
  ⟨data.1.uset i d h, (Array.size_uset ..).symm ▸ data.2⟩

/--
The number of elements in the bucket array.
Note: this is marked `noncomputable` because it is only intended for specification.
-/
noncomputable def size (data : Bucket α β) : Nat := .sum (data.1.data.map (·.toList.length))

/-- Map a function over the values in the map. -/
@[specialize] def mapVal (f : α → β → γ) (self : Bucket α β) : Bucket α γ :=
  ⟨self.1.map (.mapVal f), by simp [self.2]⟩

/--
The well-formedness invariant for the bucket array says that every element hashes to its index
(assuming the hash is lawful - otherwise there are no promises about where elements are located).
-/
structure WF [BEq α] [Hashable α] (buckets : Bucket α β) : Prop where
  /-- The elements of a bucket are all distinct according to the `BEq` relation. -/
  distinct [LawfulHashable α] [PartialEquivBEq α] : ∀ bucket ∈ buckets.1.data,
    bucket.toList.Pairwise fun a b => ¬(a.1 == b.1)
  /-- Every element in a bucket should hash to its location. -/
  hash_self (i : Nat) (h : i < buckets.1.size) :
    buckets.1[i].All fun k _ => ((hash k).toUSize % buckets.1.size).toNat = i

end Bucket
end Imp

/-- `HashMap.Imp α β` is the internal implementation type of `HashMap α β`. -/
structure Imp (α : Type u) (β : Type v) where
  /-- The number of elements stored in the `HashMap`.
  We cache this both so that we can implement `.size` in `O(1)`, and also because we
  use the size to determine when to resize the map. -/
  size    : Nat
  /-- The bucket array of the `HashMap`. -/
  buckets : Imp.Bucket α β

namespace Imp

/--
Given a desired capacity, this returns the number of buckets we should reserve.
A "load factor" of 0.75 is the usual standard for hash maps, so we return `capacity * 4 / 3`.
-/
@[inline] def numBucketsForCapacity (capacity : Nat) : Nat :=
  capacity * 4 / 3

/-- Constructs an empty hash map with the specified nonzero number of buckets. -/
@[inline] def empty' (buckets := 8) (h : 0 < buckets := by decide) : Imp α β :=
  ⟨0, .mk buckets h⟩

/-- Constructs an empty hash map with the specified target capacity. -/
def empty (capacity := 0) : Imp α β :=
  let nbuckets := numBucketsForCapacity capacity
  let n : {n : Nat // 0 < n} :=
    if h : nbuckets = 0 then ⟨8, by decide⟩
    else ⟨nbuckets, Nat.zero_lt_of_ne_zero h⟩
  empty' n n.2

/-- Calculates the bucket index from a hash value `u`. -/
def mkIdx {n : Nat} (h : 0 < n) (u : USize) : {u : USize // u.toNat < n} :=
  ⟨u % n, USize.modn_lt _ h⟩

/--
Inserts a key-value pair into the bucket array. This function assumes that the data is not
already in the array, which is appropriate when reinserting elements into the array after a resize.
-/
@[inline] def reinsertAux [Hashable α]
    (data : Bucket α β) (a : α) (b : β) : Bucket α β :=
  let ⟨i, h⟩ := mkIdx data.2 (hash a |>.toUSize)
  data.update i (.cons a b data.1[i]) h

/-- Folds a monadic function over the elements in the map (in arbitrary order). -/
@[inline] def foldM [Monad m] (f : δ → α → β → m δ) (d : δ) (map : Imp α β) : m δ :=
  map.buckets.1.foldlM (init := d) fun d b => b.foldlM f d

/-- Folds a function over the elements in the map (in arbitrary order). -/
@[inline] def fold (f : δ → α → β → δ) (d : δ) (m : Imp α β) : δ :=
  Id.run $ foldM f d m

/-- Runs a monadic function over the elements in the map (in arbitrary order). -/
@[inline] def forM [Monad m] (f : α → β → m PUnit) (h : Imp α β) : m PUnit :=
  h.buckets.1.forM fun b => b.forM f

/-- Given a key `a`, returns a key-value pair in the map whose key compares equal to `a`. -/
def findEntry? [BEq α] [Hashable α] (m : Imp α β) (a : α) : Option (α × β) :=
  let ⟨_, buckets⟩ := m
  let ⟨i, h⟩ := mkIdx buckets.2 (hash a |>.toUSize)
  buckets.1[i].findEntry? a

/-- Looks up an element in the map with key `a`. -/
def find? [BEq α] [Hashable α] (m : Imp α β) (a : α) : Option β :=
  let ⟨_, buckets⟩ := m
  let ⟨i, h⟩ := mkIdx buckets.2 (hash a |>.toUSize)
  buckets.1[i].find? a

/-- Returns true if the element `a` is in the map. -/
def contains [BEq α] [Hashable α] (m : Imp α β) (a : α) : Bool :=
  let ⟨_, buckets⟩ := m
  let ⟨i, h⟩ := mkIdx buckets.2 (hash a |>.toUSize)
  buckets.1[i].contains a

/-- Copies all the entries from `buckets` into a new hash map with a larger capacity. -/
def expand [Hashable α] (size : Nat) (buckets : Bucket α β) : Imp α β :=
  let nbuckets := buckets.1.size * 2
  { size, buckets := go 0 buckets.1 (.mk nbuckets (Nat.mul_pos buckets.2 (by decide))) }
where
  /-- Inner loop of `expand`. Copies elements `source[i:]` into `target`,
  destroying `source` in the process. -/
  go (i : Nat) (source : Array (AssocList α β)) (target : Bucket α β) : Bucket α β :=
    if h : i < source.size then
      let idx : Fin source.size := ⟨i, h⟩
      let es := source.get idx
      -- We remove `es` from `source` to make sure we can reuse its memory cells
      -- when performing es.foldl
      let source := source.set idx .nil
      let target := es.foldl reinsertAux target
      go (i+1) source target
    else target
termination_by _ i source _ => source.size - i

/--
Inserts key-value pair `a, b` into the map.
If an element equal to `a` is already in the map, it is replaced by `b`.
-/
@[inline] def insert [BEq α] [Hashable α] (m : Imp α β) (a : α) (b : β) : Imp α β :=
  let ⟨size, buckets⟩ := m
  let ⟨i, h⟩ := mkIdx buckets.2 (hash a |>.toUSize)
  let bkt := buckets.1[i]
  bif bkt.contains a then
    ⟨size, buckets.update i (bkt.replace a b) h⟩
  else
    let size' := size + 1
    let buckets' := buckets.update i (.cons a b bkt) h
    if numBucketsForCapacity size' ≤ buckets.1.size then
      { size := size', buckets := buckets' }
    else
      expand size' buckets'

/--
Removes key `a` from the map. If it does not exist in the map, the map is returned unchanged.
-/
def erase [BEq α] [Hashable α] (m : Imp α β) (a : α) : Imp α β :=
  let ⟨size, buckets⟩ := m
  let ⟨i, h⟩ := mkIdx buckets.2 (hash a |>.toUSize)
  let bkt := buckets.1[i]
  bif bkt.contains a then ⟨size - 1, buckets.update i (bkt.erase a) h⟩ else m

/-- Map a function over the values in the map. -/
@[inline] def mapVal (f : α → β → γ) (self : Imp α β) : Imp α γ :=
  { size := self.size, buckets := self.buckets.mapVal f }

/--
Applies `f` to each key-value pair `a, b` in the map. If it returns `some c` then
`a, c` is pushed into the new map; else the key is removed from the map.
-/
@[specialize] def filterMap {α : Type u} {β : Type v} {γ : Type w}
    (f : α → β → Option γ) (m : Imp α β) : Imp α γ :=
  let m' := m.buckets.1.mapM (m := StateT (ULift Nat) Id) (go .nil) |>.run ⟨0⟩ |>.run
  have : m'.1.size > 0 := by
    have := Array.size_mapM (m := StateT (ULift Nat) Id) (go .nil) m.buckets.1
    simp [SatisfiesM_StateT_eq, SatisfiesM_Id_eq] at this
    simp [this, Id.run, StateT.run, m.2.2]
  ⟨m'.2.1, m'.1, this⟩
where
  /-- Inner loop of `filterMap`. Note that this reverses the bucket lists,
  but this is fine since bucket lists are unordered. -/
  @[specialize] go (acc : AssocList α γ) : AssocList α β → ULift Nat → AssocList α γ × ULift Nat
  | .nil, n => (acc, n)
  | .cons a b l, n => match f a b with
    | none => go acc l n
    | some c => go (.cons a c acc) l ⟨n.1 + 1⟩

/-- Constructs a map with the set of all pairs `a, b` such that `f` returns true. -/
@[inline] def filter (f : α → β → Bool) (m : Imp α β) : Imp α β :=
  m.filterMap fun a b => bif f a b then some b else none

/--
The well-formedness invariant for a hash map. The first constructor is the real invariant,
and the others allow us to "cheat" in this file and define `insert` and `erase`,
which have more complex proofs that are delayed to `Std.Data.HashMap.Lemmas`.
-/
inductive WF [BEq α] [Hashable α] : Imp α β → Prop where
  /-- The real well-formedness invariant:
  * The `size` field should match the actual number of elements in the map
  * The bucket array should be well-formed, meaning that if the hashable instance
    is lawful then every element hashes to its index. -/
  | mk : m.size = m.buckets.size → m.buckets.WF → WF m
  /-- The empty hash map is well formed. -/
  | empty' : WF (empty' n h)
  /-- Inserting into a well formed hash map yields a well formed hash map. -/
  | insert : WF m → WF (insert m a b)
  /-- Removing an element from a well formed hash map yields a well formed hash map. -/
  | erase : WF m → WF (erase m a)

theorem WF.empty [BEq α] [Hashable α] : WF (empty n : Imp α β) := by unfold empty; apply empty'

end Imp

/--
`HashMap α β` is a key-value map which stores elements in an array using a hash function
to find the values. This allows it to have very good performance for lookups
(average `O(1)` for a perfectly random hash function), but it is not a persistent data structure,
meaning that one should take care to use the map linearly when performing updates.
Copies are `O(n)`.
-/
def _root_.Std.HashMap (α : Type u) (β : Type v) [BEq α] [Hashable α] := {m : Imp α β // m.WF}

open HashMap.Imp

/-- Make a new hash map with the specified capacity. -/
@[inline] def _root_.Std.mkHashMap [BEq α] [Hashable α] (capacity := 0) : HashMap α β :=
  ⟨.empty capacity, .empty⟩

instance [BEq α] [Hashable α] : Inhabited (HashMap α β) where
  default := mkHashMap

instance [BEq α] [Hashable α] : EmptyCollection (HashMap α β) := ⟨mkHashMap⟩

/-- Make a new empty hash map. -/
@[inline] def empty [BEq α] [Hashable α] : HashMap α β := mkHashMap

variable {_ : BEq α} {_ : Hashable α}

/-- The number of elements in the hash map. -/
@[inline] def size (self : HashMap α β) : Nat := self.1.size

/-- Is the map empty? -/
@[inline] def isEmpty (self : HashMap α β) : Bool := self.size = 0

/--
Inserts key-value pair `a, b` into the map.
If an element equal to `a` is already in the map, it is replaced by `b`.
-/
def insert (self : HashMap α β) (a : α) (b : β) : HashMap α β := ⟨self.1.insert a b, self.2.insert⟩

/--
Similar to `insert`, but also returns a boolean flag indicating whether an existing entry has been
replaced with `a ↦ b`.
-/
@[inline] def insert' (m : HashMap α β) (a : α) (b : β) : HashMap α β × Bool :=
  let old := m.size
  let m' := m.insert a b
  let replaced := old == m'.size
  (m', replaced)

/--
Removes key `a` from the map. If it does not exist in the map, the map is returned unchanged.
-/
@[inline] def erase (self : HashMap α β) (a : α) : HashMap α β := ⟨self.1.erase a, self.2.erase⟩

/-- Given a key `a`, returns a key-value pair in the map whose key compares equal to `a`. -/
@[inline] def findEntry? (self : HashMap α β) (a : α) : Option (α × β) := self.1.findEntry? a

/-- Looks up an element in the map with key `a`. -/
@[inline] def find? (self : HashMap α β) (a : α) : Option β := self.1.find? a

/-- Looks up an element in the map with key `a`. Returns `b₀` if the element is not found. -/
@[inline] def findD (self : HashMap α β) (a : α) (b₀ : β) : β := (self.find? a).getD b₀

/-- Looks up an element in the map with key `a`. Panics if the element is not found. -/
@[inline] def find! [Inhabited β] (self : HashMap α β) (a : α) : β :=
  (self.find? a).getD (panic! "key is not in the map")

instance : GetElem (HashMap α β) α (Option β) fun _ _ => True where
  getElem m k _ := m.find? k

/-- Returns true if the element `a` is in the map. -/
@[inline] def contains (self : HashMap α β) (a : α) : Bool := self.1.contains a

/-- Folds a monadic function over the elements in the map (in arbitrary order). -/
@[inline] def foldM [Monad m] (f : δ → α → β → m δ) (init : δ) (self : HashMap α β) : m δ :=
  self.1.foldM f init

/-- Folds a function over the elements in the map (in arbitrary order). -/
@[inline] def fold (f : δ → α → β → δ) (init : δ) (self : HashMap α β) : δ := self.1.fold f init

/-- Combines two hashmaps using a monadic function `f` to combine two values at a key. -/
@[specialize] def mergeWithM [Monad m] (f : α → β → β → m β)
    (self other : HashMap α β) : m (HashMap α β) :=
  other.foldM (init := self) fun m k v₂ =>
    match m.find? k with
    | none => return m.insert k v₂
    | some v₁ => return m.insert k (← f k v₁ v₂)

/-- Combines two hashmaps using function `f` to combine two values at a key. -/
@[inline] def mergeWith (f : α → β → β → β) (self other : HashMap α β) : HashMap α β :=
  -- Implementing this function directly, rather than via `mergeWithM`, gives
  -- us less constrained universes.
  other.fold (init := self) λ map k v₂ =>
    match map.find? k with
    | none => map.insert k v₂
    | some v₁ => map.insert k $ f k v₁ v₂

/-- Runs a monadic function over the elements in the map (in arbitrary order). -/
@[inline] def forM [Monad m] (f : α → β → m PUnit) (self : HashMap α β) : m PUnit := self.1.forM f

/-- Converts the map into a list of key-value pairs. -/
def toList (self : HashMap α β) : List (α × β) := self.fold (init := []) fun r k v => (k, v)::r

/-- Converts the map into an array of key-value pairs. -/
def toArray (self : HashMap α β) : Array (α × β) :=
  self.fold (init := #[]) fun r k v => r.push (k, v)

/-- The number of buckets in the hash map. -/
def numBuckets (self : HashMap α β) : Nat := self.1.buckets.1.size

/--
Builds a `HashMap` from a list of key-value pairs.
Values of duplicated keys are replaced by their respective last occurrences.
-/
def ofList (l : List (α × β)) : HashMap α β :=
  l.foldl (init := HashMap.empty) fun m (k, v) => m.insert k v

/-- Variant of `ofList` which accepts a function that combines values of duplicated keys. -/
def ofListWith (l : List (α × β)) (f : β → β → β) : HashMap α β :=
  l.foldl (init := HashMap.empty) fun m p =>
    match m.find? p.1 with
    | none   => m.insert p.1 p.2
    | some v => m.insert p.1 <| f v p.2


/- -----------------------------------------------------------------------
Algebras for endofunctors.
----------------------------------------------------------------------- -/

import ..c1_basic
import ..c2_limits

namespace qp

open stdaux

universe variables ℓobj ℓhom

/- -----------------------------------------------------------------------
The category of algebras for an endofunctor.
----------------------------------------------------------------------- -/

/-! #brief An algebra for an endofunctor.
-/
structure EndoAlg {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
    : Type (max ℓobj ℓhom)
:= (carr : C^.obj)
   (hom : C^.hom (F^.obj carr) carr)

/-! #brief Helper for proving equality of EndoAlg.
-/
theorem EndoAlg.eq {C : Cat.{ℓobj ℓhom}} {F : Fun C C}
    : ∀ {X₁ X₂ : EndoAlg F}
        (ωcarr : X₁^.carr = X₂^.carr)
        (ωhom : (X₁^.carr = X₂^.carr) → X₁^.hom == X₂^.hom)
      , X₁ = X₂
| (EndoAlg.mk carr hom₁) (EndoAlg.mk .(carr) hom₂)
  (eq.refl .(carr)) ωhom
:= begin
     assert ωhom' : hom₁ = hom₂,
     { apply eq_of_heq, exact ωhom rfl },
     subst ωhom'
   end

/-! #brief An algebra homomorphism for an endofunctor.
-/
structure EndoAlgHom {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
    (X Y : EndoAlg F)
    : Type (max ℓobj ℓhom)
:= (hom : C^.hom X^.carr Y^.carr)
   (comm : C^.circ Y^.hom (F^.hom hom) = C^.circ hom X^.hom)

/-! #brief Congruence for endo algebra homomorphisms.
-/
theorem EndoAlgHom.congr_hom {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
    {X Y : EndoAlg F}
    : ∀ (h₁ h₂ : EndoAlgHom F X Y)
        (ω : h₁ = h₂)
      , h₁^.hom = h₂^.hom
| h .(h) (eq.refl .(h)) := rfl

/-! #brief A helper for proving two homomorphisms are equal.
-/
theorem EndoAlgHom.eq {C : Cat.{ℓobj ℓhom}} {F : Fun C C}
    {X Y : EndoAlg F}
    : ∀ {F₁ F₂ : EndoAlgHom F X Y}
        (ω : F₁^.hom = F₂^.hom)
      , F₁ = F₂
| (EndoAlgHom.mk hom comm₁) (EndoAlgHom.mk .(hom) comm₂) (eq.refl .(hom))
:= rfl

/-! #brief A helper for proving two homomorphisms are heterogeneously equal.
-/
theorem EndoAlgHom.heq {C : Cat.{ℓobj ℓhom}} {F : Fun C C}
    : ∀ {X₁ Y₁ X₂ Y₂ : EndoAlg F}
        {F₁ : EndoAlgHom F X₁ Y₁} {F₂ : EndoAlgHom F X₂ Y₂}
        (ωX : X₁ = X₂) (ωY : Y₁ = Y₂)
        (ωF : F₁^.hom == F₂^.hom)
      , F₁ == F₂
| X Y .(X) .(Y) (EndoAlgHom.mk f ω₁) (EndoAlgHom.mk .(f) ω₂)
(eq.refl .(X)) (eq.refl .(Y)) (heq.refl .(f))
:= heq.refl _

/-! #brief The identity homomorphism.
-/
definition EndoAlgHom.id {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
    (X : EndoAlg F)
    : EndoAlgHom F X X
:= { hom := C^.id X^.carr
   , comm := by rw [F^.hom_id, C^.circ_id_right, C^.circ_id_left]
   }

/-! #brief The composition of two homomorphisms.
-/
definition EndoAlgHom.comp {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
    {X Y Z : EndoAlg F}
    (g : EndoAlgHom F Y Z)
    (f : EndoAlgHom F X Y)
    : EndoAlgHom F X Z
:= { hom := C^.circ g^.hom f^.hom
   , comm
      := begin
           rw [-C^.circ_assoc, -f^.comm],
           rw [C^.circ_assoc, -g^.comm],
           rw [-C^.circ_assoc, F^.hom_circ]
         end
   }

/-! #brief The category of algebras for an endofunctor.
-/
definition EndoAlgCat {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
    : Cat
:= { obj := EndoAlg F
   , hom := EndoAlgHom F
   , id := EndoAlgHom.id F
   , circ := @EndoAlgHom.comp C F
   , circ_assoc := λ X Y Z W h g f, EndoAlgHom.eq C^.circ_assoc
   , circ_id_left := λ X Y f, EndoAlgHom.eq C^.circ_id_left
   , circ_id_right := λ X Y f, EndoAlgHom.eq C^.circ_id_right
   }

/-! #brief Natural transformations induce functors between algebra categories.
-/
definition NatTrans.EndoAlgFun {C : Cat.{ℓobj ℓhom}}
    {F₁ F₂ : Fun C C}
    (η : NatTrans F₁ F₂)
    : Fun (EndoAlgCat F₂) (EndoAlgCat F₁)
:= { obj := λ alg, { carr := alg^.carr
                   , hom := alg^.hom ∘∘ η^.com alg^.carr
                   }
   , hom := λ alg₁ alg₂ f
            , { hom := f^.hom
              , comm := begin
                          apply eq.trans (eq.symm C^.circ_assoc),
                          rw η^.natural f^.hom,
                          apply eq.trans C^.circ_assoc,
                          apply eq.trans (Cat.circ.congr_left f^.comm),
                          exact eq.symm C^.circ_assoc
                        end
              }
   , hom_id := λ alg₁, rfl
   , hom_circ := λ alg₁ alg₂ alg₃ g f, rfl
   }

/-! #brief Natural isomorphisms induce bijections of algebra categories.
-/
definition NatIso.EndoAlgBij.lem₁ {C : Cat.{ℓobj ℓhom}}
    {F₁ F₂ : Fun C C}
    {η₁₂ : NatTrans F₁ F₂}
    {η₂₁ : NatTrans F₂ F₁}
    (η_iso : NatIso η₁₂ η₂₁)
    : NatTrans.EndoAlgFun η₁₂ □□ NatTrans.EndoAlgFun η₂₁ = Fun.id (EndoAlgCat F₁)
:= Fun.eq
    (λ alg
     , EndoAlg.eq rfl
         (λ ω, heq_of_eq
                 begin
                   apply eq.trans (eq.symm C^.circ_assoc),
                   refine eq.symm (eq.trans (eq.symm C^.circ_id_right) (eq.symm _)),
                   apply Cat.circ.congr_right,
                   exact (η_iso^.com alg^.carr)^.id₁
                 end))
    (λ ω alg₁ alg₂ f
     , begin
         apply EndoAlgHom.heq (ω alg₁) (ω alg₂),
         apply heq.refl
       end)

/-! #brief Natural isomorphisms induce bijections of algebra categories.
-/
definition NatIso.EndoAlgBij {C : Cat.{ℓobj ℓhom}}
    {F₁ F₂ : Fun C C}
    {η₁₂ : NatTrans F₁ F₂}
    {η₂₁ : NatTrans F₂ F₁}
    (η_iso : NatIso η₁₂ η₂₁)
    : Cat.Bij η₂₁^.EndoAlgFun η₁₂^.EndoAlgFun
:= { id₁ := NatIso.EndoAlgBij.lem₁ η_iso
   , id₂ := NatIso.EndoAlgBij.lem₁ η_iso^.flip
   }

/- -----------------------------------------------------------------------
Initial algebras.
----------------------------------------------------------------------- -/

/-! #brief Initial objects in EndoAlgCat are special.
-/
@[class] definition HasInitAlg {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
:= HasInit (EndoAlgCat F)

/-! #brief Initial algebras are preserved by natural isomorphisms.
-/
definition NatIso.EndoAlgBij.HasInitAlg₁ {C : Cat.{ℓobj ℓhom}}
    {F₁ F₂ : Fun C C}
    (F₂_HasInitAlg : HasInitAlg F₂)
    {η₁₂ : NatTrans F₁ F₂}
    {η₂₁ : NatTrans F₂ F₁}
    (η_iso : NatIso η₁₂ η₂₁)
    : HasInitAlg F₁
:= @PresInit.HasInit _ _ F₂_HasInitAlg
      η₁₂^.EndoAlgFun η_iso^.EndoAlgBij^.PresInit₂

/-! #brief Initial algebras are preserved by natural isomorphisms.
-/
definition NatIso.EndoAlgBij.HasInitAlg₂ {C : Cat.{ℓobj ℓhom}}
    {F₁ F₂ : Fun C C}
    (F₁_HasInitAlg : HasInitAlg F₁)
    {η₁₂ : NatTrans F₁ F₂}
    {η₂₁ : NatTrans F₂ F₁}
    (η_iso : NatIso η₁₂ η₂₁)
    : HasInitAlg F₂
:= NatIso.EndoAlgBij.HasInitAlg₁ F₁_HasInitAlg η_iso^.flip

/-! #brief An initial algebra.
-/
definition initalg {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
    [F_HasInitAlg : HasInitAlg F]
    : EndoAlg F
:= @init _ F_HasInitAlg

/-! #brief The carrier of an initial algebra.
-/
definition initalg.carr {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
    [F_HasInitAlg : HasInitAlg F]
    : C^.obj
:= (initalg F)^.carr

/-! #brief The structure hom of an initial algebra.
-/
definition initalg.hom {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
    [F_HasInitAlg : HasInitAlg F]
    : C^.hom (F^.obj (initalg.carr F)) (initalg.carr F)
:= (initalg F)^.hom

/-! #brief Doubling the initial algebra.
-/
definition initalg.double {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
    [F_HasInitAlg : HasInitAlg F]
    : EndoAlg F
:= { carr := F^.obj (initalg.carr F)
   , hom := F^.hom (initalg.hom F)
   }

/-! #brief The inverse structure hom of an initial algebra.
-/
definition initalg.unhom {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
    [F_HasInitAlg : HasInitAlg F]
    : C^.hom (initalg.carr F) (F^.obj (initalg.carr F))
:= (@init_hom _ F_HasInitAlg (initalg.double F))^.hom

/-! #brief initalg.hom and initalg.unhom are an iso pair.
-/
definition initalg.iso {C : Cat.{ℓobj ℓhom}} (F : Fun C C)
    [F_HasInitAlg : HasInitAlg F]
    : Iso (initalg.hom F) (initalg.unhom F)
:= let φ : EndoAlgHom F (initalg F) (initalg F)
        := { hom := C^.circ (initalg.hom F) (initalg.unhom F)
           , comm := begin
                       repeat { rw -C^.circ_assoc },
                       apply Cat.circ.congr_right,
                       apply eq.trans F^.hom_circ,
                       exact (@init_hom _ F_HasInitAlg (initalg.double F))^.comm
                     end
           }
in let ωφ : φ = EndoAlgHom.id F (initalg F)
         := init_hom.uniq' (EndoAlgCat F)
in let ω : initalg.hom F ∘∘ initalg.unhom F = ⟨⟨initalg.carr F⟩⟩
        := begin
              refine @eq.trans _ _ φ^.hom _ rfl _,
              refine @eq.trans _ _ (EndoAlgHom.id F _)^.hom _ _ rfl,
              rw ωφ
            end
in { id₁ := begin
              apply eq.symm,
              apply eq.trans (eq.symm F^.hom_id),
              refine eq.trans _ (@init_hom _ F_HasInitAlg (initalg.double F))^.comm,
              refine eq.trans _ F^.hom_circ,
              exact congr_arg _ (eq.symm ω),
            end
   , id₂ := ω
   }

/- -----------------------------------------------------------------------
Adámek's theorem.
----------------------------------------------------------------------- -/

/-! #brief Action of the functor used in Adámek's construction on objects.
-/
definition AdamekFun.obj {C : Cat.{ℓobj ℓhom}}
    [C_HasInit : HasInit C]
    (F : Fun C C)
    (n : ℕ)
    : C^.obj
:= (Fun.iter_comp F n)^.obj (init C)

@[simp] theorem AdamekFun.obj.simp {C : Cat.{ℓobj ℓhom}}
    [C_HasInit : HasInit C]
    {F : Fun C C}
    {n : ℕ}
    : AdamekFun.obj F (nat.succ n) = F^.obj (AdamekFun.obj F n)
:= rfl

/-! #brief Action of the functor used in Adámek's construction on homs.
-/
definition AdamekFun.hom {C : Cat.{ℓobj ℓhom}}
    [C_HasInit : HasInit C]
    (F : Fun C C)
    : ∀ (n₁ n₂ : ℕ) (m : ℕ) (ωm : n₂ = m + n₁)
      , C^.hom (AdamekFun.obj F n₁) (AdamekFun.obj F n₂)
| 0 .(m) m (eq.refl .(m)) := init_hom (AdamekFun.obj F m)
| (nat.succ n₁) .(m + nat.succ n₁) m (eq.refl .(m + nat.succ n₁))
:= F^.hom (AdamekFun.hom n₁ (m + n₁) m rfl)

@[simp] theorem AdamekFun.hom.simp {C : Cat.{ℓobj ℓhom}}
    [C_HasInit : HasInit C]
    {F : Fun C C}
    : ∀ {n₁ n₂ : ℕ} {m : ℕ} {ωm : nat.succ n₂ = m + nat.succ n₁}
      , AdamekFun.hom F (nat.succ n₁) (nat.succ n₂) m ωm
         = F^.hom (AdamekFun.hom F n₁ n₂ m (nat.succ.inj ωm))
| 0 .(m) m (eq.refl .(nat.succ m)) := rfl
| (nat.succ n₁) .(m + nat.succ n₁) m (eq.refl .(nat.succ (m + nat.succ n₁)))
:= rfl

/-! #brief Congruence for the Adámek functor on homs.
-/
definition AdamekFun.hcongr_hom {C : Cat.{ℓobj ℓhom}}
    [C_HasInit : HasInit C]
    {F : Fun C C}
    : ∀ {n₁ n₂ : ℕ} {m : ℕ} {ωm : n₂ = m + n₁}
        (p₁ p₂ : ℕ) (q : ℕ)
        (ωnp₁ : n₁ = p₁)
        (ωnp₂ : n₂ = p₂)
        (ωmq : m = q)
      , AdamekFun.hom F n₁ n₂ m ωm
         == AdamekFun.hom F p₁ p₂ q begin subst ωnp₁, subst ωnp₂, subst ωmq, exact ωm end
| n₁ n₂ m ωm .(n₁) .(n₂) .(m)
(eq.refl .(n₁)) (eq.refl .(n₂)) (eq.refl .(m))
:= heq.refl _

/-! #brief Congruence for the Adámek functor on homs.
-/
definition AdamekFun.congr_hom {C : Cat.{ℓobj ℓhom}}
    [C_HasInit : HasInit C]
    {F : Fun C C}
    : ∀ {n₁ n₂ : ℕ} {m : ℕ} {ωm : n₂ = m + n₁}
        (q : ℕ)
        (ωmq : m = q)
      , AdamekFun.hom F n₁ n₂ m ωm
         = AdamekFun.hom F n₁ n₂ q begin subst ωmq, exact ωm end
| n₁ n₂ m ωm .(m) (eq.refl .(m)) := rfl

/-! #brief The functor used in Adámek's construction.
-/
definition AdamekFun {C : Cat.{ℓobj ℓhom}}
    [C_HasInit : HasInit C]
    (F : Fun C C)
    : Fun NatCat C
:= { obj := AdamekFun.obj F
   , hom := λ x y ωxy, AdamekFun.hom F x y (y - x) (eq.symm (nat.sub_add_cancel ωxy))
   , hom_id
      := λ n
         , begin
             dsimp [NatCat] at n,
             induction n with n rec,
             { apply eq.symm, apply init_hom.uniq },
             simp,
             exact eq.trans (Fun.congr_hom rec) F^.hom_id,
           end
   , hom_circ
      := λ x y z g f
         , sorry
   }

/-! #brief Structure hom for the co-cone used in Adámek's construction.
-/
definition Adamek.CoCone.hom {C : Cat.{ℓobj ℓhom}}
    [C_HasInit : HasInit C]
    (F : Fun C C)
    (x : EndoAlg F)
    : ∀ (n : ℕ)
      , C^.hom (AdamekFun.obj F n) x^.carr
| 0 := (init_hom x^.carr)
| (nat.succ n) := C^.circ x^.hom (F^.hom (Adamek.CoCone.hom n))

/-! #brief Commutative property for the co-cone used in Adámek's construction.
-/
definition Adamek.CoCone.comm {C : Cat.{ℓobj ℓhom}}
    [C_HasInit : HasInit C]
    (F : Fun C C)
    (x : EndoAlg F)
    : ∀ {n₁ n₂ : ℕ} (ωn : n₁ ≤ n₂)
      , Adamek.CoCone.hom F x n₁
         = Adamek.CoCone.hom F x n₂
            ∘∘ AdamekFun.hom F n₁ n₂ (n₂ - n₁) (eq.symm (nat.sub_add_cancel ωn))
| 0 n₂ ωn := init_hom.uniq' _
| (nat.succ n₁) 0 ωn := by cases ωn
| (nat.succ n₁) (nat.succ n₂) ωn
:= begin
     dsimp [Adamek.CoCone.hom],
     rw -C^.circ_assoc,
     apply Cat.circ.congr_right,
     simp,
     refine eq.trans _ F^.hom_circ,
     apply Fun.congr_hom,
     apply Adamek.CoCone.comm (nat.le_of_succ_le_succ ωn),
   end

/-! #brief The co-cone used in Adámek's construction.
-/
definition Adamek.CoCone {C : Cat.{ℓobj ℓhom}}
    [C_HasInit : HasInit C]
    (F : Fun C C)
    (x : EndoAlg F)
    : CoCone (AdamekFun F)
:= CoCone.mk
    x^.carr
    (Adamek.CoCone.hom F x)
    (λ n₁ n₂ ωn , Adamek.CoCone.comm F x ωn)

/-! #brief Adámek's construction of initial algebras.
-/
definition Adamek {C : Cat.{ℓobj ℓhom}}
    [C_HasInit : HasInit C]
    (F : Fun C C)
    [Adamek_HasCoLimit : HasCoLimit (AdamekFun F)]
    [F_PresCoLimit : PresCoLimit (AdamekFun F) F]
    : HasInitAlg F
:= HasInit.show
    { carr := colimit (AdamekFun F)
    , hom := let ccone : CoCone (F □□ AdamekFun F)
                      := CoCone.mk
                          (colimit (AdamekFun F))
                          (λ n, colimit.in (AdamekFun F) (nat.succ n))
                          (λ n₁ n₂ ωn, sorry)
             in let f : C^.hom (colimit (F □□ AdamekFun F)) (colimit (AdamekFun F))
                     := colimit.univ _ ccone
             in f ∘∘ cast_hom (prescolimit (AdamekFun F) F)

    }
    (λ A, { hom := colimit.univ _ (Adamek.CoCone F A)
          , comm := sorry
          })
    (λ A h
     , EndoAlgHom.eq
        begin
          cases h with h ωh, dsimp at ωh, dsimp,
          apply colimit.univ.uniq (Adamek.CoCone F A),
          intro n, dsimp [Adamek.CoCone, CoCone.mk],
          induction n with n rec,
          { apply init_hom.uniq' },
          { dsimp [Adamek.CoCone.hom],
            rw rec,
            apply eq.trans (Cat.circ.congr_right F^.hom_circ),
            apply eq.trans C^.circ_assoc,
            apply eq.trans (Cat.circ.congr_left ωh),
            rw -C^.circ_assoc,
            apply Cat.circ.congr_right,
            exact sorry
          }
        end)

end qp


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import logic.small
import category_theory.skeletal

/-!
# Essentially small categories.

A category given by `(C : Type u) [category.{v} C]` is `w`-essentially small
if there exists a `small_model C : Type w` equipped with `[small_category (small_model C)]`.

A category is `w`-locally small if every hom type is `w`-small.

The main theorem here is that a category is `w`-essentially small iff
the type `skeleton C` is `w`-small, and `C` is `w`-locally small.
-/

universes w v v' u u'

open category_theory

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

namespace category_theory

/-- A category is `essentially_small.{w}` if there exists
an equivalence to some `S : Type w` with `[small_category S]`. -/
class essentially_small (C : Type u) [category.{v} C] : Prop :=
(equiv_small_category : ∃ (S : Type w) (_ : small_category S), by exactI nonempty (C ≌ S))

/-- Constructor for `essentially_small C` from an explicit small category witness. -/

/--
An arbitrarily chosen small model for an essentially small category.
-/
@[nolint has_inhabited_instance]
def small_model (C : Type u) [category.{v} C] [essentially_small.{w} C] : Type w :=
classical.some (@essentially_small.equiv_small_category C _ _)

noncomputable
instance small_category_small_model
  (C : Type u) [category.{v} C] [essentially_small.{w} C] : small_category (small_model C) :=
classical.some (classical.some_spec (@essentially_small.equiv_small_category C _ _))

/--
The (noncomputable) categorical equivalence between
an essentially small category and its small model.
-/
noncomputable
def equiv_small_model (C : Type u) [category.{v} C] [essentially_small.{w} C] : C ≌ small_model C :=
nonempty.some (classical.some_spec (classical.some_spec
  (@essentially_small.equiv_small_category C _ _)))

lemma essentially_small_congr {C : Type u} [category.{v} C] {D : Type u'} [category.{v'} D]
  (e : C ≌ D) : essentially_small.{w} C ↔ essentially_small.{w} D :=
begin
  fsplit,
  { rintro ⟨S, 𝒮, ⟨f⟩⟩,
    resetI,
    exact essentially_small.mk' (e.symm.trans f), },
  { rintro ⟨S, 𝒮, ⟨f⟩⟩,
    resetI,
    exact essentially_small.mk' (e.trans f), },
end

/--
A category is `w`-locally small if every hom set is `w`-small.

See `shrink_homs C` for a category instance where every hom set has been replaced by a small model.
-/
class locally_small (C : Type u) [category.{v} C] : Prop :=
(hom_small : ∀ X Y : C, small.{w} (X ⟶ Y) . tactic.apply_instance)

instance (C : Type u) [category.{v} C] [locally_small.{w} C] (X Y : C) :
  small (X ⟶ Y) :=
locally_small.hom_small X Y

lemma locally_small_congr {C : Type u} [category.{v} C] {D : Type u'} [category.{v'} D]
  (e : C ≌ D) : locally_small.{w} C ↔ locally_small.{w} D :=
begin
  fsplit,
  { rintro ⟨L⟩,
    fsplit,
    intros X Y,
    specialize L (e.inverse.obj X) (e.inverse.obj Y),
    refine (small_congr _).mpr L,
    exact equiv_of_fully_faithful e.inverse, },
  { rintro ⟨L⟩,
    fsplit,
    intros X Y,
    specialize L (e.functor.obj X) (e.functor.obj Y),
    refine (small_congr _).mpr L,
    exact equiv_of_fully_faithful e.functor, },
end

@[priority 100]
instance locally_small_self (C : Type u) [category.{v} C] : locally_small.{v} C := {}

@[priority 100]
instance locally_small_of_essentially_small
  (C : Type u) [category.{v} C] [essentially_small.{w} C] : locally_small.{w} C :=
(locally_small_congr (equiv_small_model C)).mpr (category_theory.locally_small_self _)

/--
We define a type alias `shrink_homs C` for `C`. When we have `locally_small.{w} C`,
we'll put a `category.{w}` instance on `shrink_homs C`.
-/
@[nolint has_inhabited_instance]
def shrink_homs (C : Type u) := C

namespace shrink_homs

section
variables {C' : Type*} -- a fresh variable with no category instance attached

/-- Help the typechecker by explicitly translating from `C` to `shrink_homs C`. -/
def to_shrink_homs {C' : Type*} (X : C') : shrink_homs C' := X
/-- Help the typechecker by explicitly translating from `shrink_homs C` to `C`. -/
def from_shrink_homs {C' : Type*} (X : shrink_homs C') : C' := X

@[simp] lemma to_from (X : C') : from_shrink_homs (to_shrink_homs X) = X := rfl
@[simp] lemma from_to (X : shrink_homs C') : to_shrink_homs (from_shrink_homs X) = X := rfl

end

variables (C) [locally_small.{w} C]

@[simps]
noncomputable
instance : category.{w} (shrink_homs C) :=
{ hom := λ X Y, shrink (from_shrink_homs X ⟶ from_shrink_homs Y),
  id := λ X, equiv_shrink _ (𝟙 (from_shrink_homs X)),
  comp := λ X Y Z f g,
    equiv_shrink _ (((equiv_shrink _).symm f) ≫ ((equiv_shrink _).symm g)), }.

/-- Implementation of `shrink_homs.equivalence`. -/
@[simps]
noncomputable
def functor : C ⥤ shrink_homs C :=
{ obj := λ X, to_shrink_homs X,
  map := λ X Y f, equiv_shrink (X ⟶ Y) f, }

/-- Implementation of `shrink_homs.equivalence`. -/
@[simps]
noncomputable
def inverse : shrink_homs C ⥤ C :=
{ obj := λ X, from_shrink_homs X,
  map := λ X Y f, (equiv_shrink (from_shrink_homs X ⟶ from_shrink_homs Y)).symm f, }

/--
The categorical equivalence between `C` and `shrink_homs C`, when `C` is locally small.
-/
@[simps]
noncomputable
def equivalence : C ≌ shrink_homs C :=
equivalence.mk (functor C) (inverse C)
  (nat_iso.of_components (λ X, iso.refl X) (by tidy))
  (nat_iso.of_components (λ X, iso.refl X) (by tidy))

end shrink_homs

/--
A category is essentially small if and only if
the underlying type of its skeleton (i.e. the "set" of isomorphism classes) is small,
and it is locally small.
-/
theorem essentially_small_iff (C : Type u) [category.{v} C] :
  essentially_small.{w} C ↔ small.{w} (skeleton C) ∧ locally_small.{w} C :=
begin
  -- This theorem is the only bit of real work in this file.
  fsplit,
  { intro h,
    fsplit,
    { rcases h with ⟨S, 𝒮, ⟨e⟩⟩,
      resetI,
      refine ⟨⟨skeleton S, ⟨_⟩⟩⟩,
      exact e.skeleton_equiv, },
    { resetI, apply_instance, }, },
  { rintro ⟨⟨S, ⟨e⟩⟩, L⟩,
    resetI,
    let e' := (shrink_homs.equivalence C).skeleton_equiv.symm,
    refine ⟨⟨S, _, ⟨_⟩⟩⟩,
    apply induced_category.category (e'.trans e).symm,
    refine (shrink_homs.equivalence C).trans
      ((skeleton_equivalence _).symm.trans
      ((induced_functor (e'.trans e).symm).as_equivalence.symm)), },
end

/--
Any thin category is locally small.
-/
@[priority 100]
instance locally_small_of_thin {C : Type u} [category.{v} C] [∀ X Y : C, subsingleton (X ⟶ Y)] :
  locally_small.{w} C := {}

/--
A thin category is essentially small if and only if the underlying type of its skeleton is small.
-/
theorem essentially_small_iff_of_thin
  {C : Type u} [category.{v} C] [∀ X Y : C, subsingleton (X ⟶ Y)] :
  essentially_small.{w} C ↔ small.{w} (skeleton C) :=
by simp [essentially_small_iff, category_theory.locally_small_of_thin]

end category_theory


/-
Copyright (c) 2022 Arthur Paulino. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Arthur Paulino
-/
import Mathlib.Tactic.Have

example : Nat := by
  have h : Nat
  exact 5
  exact h

example : Nat := by
  have : Nat
  · exact 5
  exact this

example {a : Nat} : a = a := by
  have h : a = a
  · rfl
  exact h

example {a : Nat} : a = a := by
  have : a = a
  · rfl
  exact this

example : True := by
  (let _N) -- FIXME: lean4#1670
  exact Nat
  have
  · exact 0
  have _h : Nat
  · exact 5
  have _h' x : x < x + 1
  · exact Nat.lt.base x
  have _h'' (x : Nat) : x < x + 1
  · exact Nat.lt.base x
  let _m
  · exact 6
  let _m' x (y : Nat) : x + y = y + x
  rw [Nat.add_comm]
  have _q
  · exact 6
  simp


import multirelation.approach2.tactic
import tactic.group1r

variables {G : Type} [group G]
  (a b c d e f g h i j k l m n o p q r s t u v w x y z : G)

set_option profiler true

-- example (h : a * b * a * b = 1) :
--   (b * a * b * a * b⁻¹ * a⁻¹ * b⁻¹ * a⁻¹ = 1) :=
-- by group1r using h

-- example (h : a * b * a * b = 1) :
--   (b * a * b * a * b⁻¹ * a⁻¹ * b⁻¹ * a⁻¹ = 1) :=
-- by group_rel [h]

-- example (h : a * b * a * b = 1) :
--   ((b⁻¹ * a⁻¹ * b⁻¹ * a⁻¹)^4  = 1) :=
-- by group1r using h

-- example (h : a * b * a * b = 1) :
--   ((b⁻¹ * a⁻¹ * b⁻¹ * a⁻¹)^4  = 1) :=
-- by group_rel [h]

-- -- example (h : a * b * a * b = 1) :
-- --   ((b * a * b * a)^100  = 1) :=
-- -- by group1r using h

-- -- example (h : a * b * a * b = 1) :
-- --   ((b * a * b * a)^100  = 1) :=
-- -- by group_rel [h]

-- -- example (h : a * b * a * b = 1) :
-- --   ((b * a * b * a)^200  = 1) :=
-- -- by group1r using h

-- example (h : a * b * a * b = 1) :
--   ((b * a * b * a)^200  = 1) :=
-- by group_rel [h]

-- example (h : a * b = b ^ 2 * a) :
--   (a * b * a ^ (-1 : ℤ) * b = b * a * b * a ^ (-1 : ℤ)) :=
-- by group1r using h

-- example (h : a * b = b ^ 2 * a) :
--   (a * b * a ^ (-1 : ℤ) * b = b * a * b * a ^ (-1 : ℤ)) :=
-- by group_rel [h]

-- example (h : a * b = b ^ 2 * a) :
--   (a ^ 5 * b * a ^ (-5 : ℤ) * b = b * a ^ 5 * b * a ^ (-5 : ℤ)) :=
-- by group1r using h

example (h : a * b = b ^ 2 * a) :
  (a ^ 6 * b * a ^ (-6 : ℤ) * b = b * a ^ 6 * b * a ^ (-6 : ℤ)) :=
by group1r using h

-- example (h : a * b = b ^ 2 * a) :
--   (a ^ 5 * b * a ^ (-5 : ℤ) * b = b * a ^ 5 * b * a ^ (-5 : ℤ)) :=
-- by group_rel [h]

-- example (h : a * b = b ^ 2 * a) :
--   (a ^ 2 * b * a ^ (-2 : ℤ) * b = b * a ^ 2 * b * a ^ (-2 : ℤ)) :=
-- by group1r using h

-- example (h : a * b = b ^ 2 * a) :
--   (a ^ 2 * b * a ^ (-2 : ℤ) * b = b * a ^ 2 * b * a ^ (-2 : ℤ)) :=
-- by group_rel [h]

-- example (h : a * b = b * a) :
--   (a ^ 2 * b ^ 2 = b ^ 2 * a ^ 2) :=
-- by group1r using h

-- example (h : a * b = b * a) :
--   (a ^ 2 * b ^ 2 = b ^ 2 * a ^ 2) :=
-- by group_rel [h]

-- example (h : a * b = b * a) :
--   (a ^ 5 * b ^ 5 = b ^ 5 * a ^ 5) :=
-- by group1r using h

-- example (h : a * b = b * a) :
--   (a ^ 5 * b ^ 5 = b ^ 5 * a ^ 5) :=
-- by group_rel [h]

-- example (h : a * b = b * a) :
--   (a ^ 10 * b ^ 10 = b ^ 10 * a ^ 10) :=
-- by group1r using h

-- example (h : a * b = b * a) :
--   (a ^ 10 * b ^ 10 = b ^ 10 * a ^ 10) :=
-- by group_rel [h]

-- example (h : a * b * a ^ (-11 : ℤ) * b ^ 4 = 1) :
--   (a ^ 10 * b * a * b * a ^ (-11 : ℤ) * b ^ 3 * a ^ (-10 : ℤ)
--     * b ^ (-4 : ℤ) * a ^ 11 * b⁻¹ * a⁻¹ = 1) :=
-- by group1r using h

-- example (h : a * b * a ^ (-11 : ℤ) * b ^ 4 = 1) :
--   (a ^ 10 * b * a * b * a ^ (-11 : ℤ) * b ^ 3 * a ^ (-10 : ℤ)
--     * b ^ (-4 : ℤ) * a ^ 11 * b⁻¹ * a⁻¹ = 1) :=
-- by group_rel [h]

-- example (h : a * (b * c) * a⁻¹ * (b * c) ^ (-2 : ℤ) = 1) :
--   a^6 * b * c * a * b * c * a⁻¹ * (b * c)^(-2 : ℤ) * c⁻¹ * b⁻¹ * a^(-5 : ℤ) *
--     (b * c) * a⁻¹ * (b * c) ^ (-2 : ℤ) = 1 :=
-- by group1r using h

-- example (h : a * (b * c) * a⁻¹ * (b * c) ^ (-2 : ℤ) = 1) :
--   a^6 * b * c * a * b * c * a⁻¹ * (b * c)^(-2 : ℤ) * c⁻¹ * b⁻¹ * a^(-5 : ℤ) *
--     (b * c) * a⁻¹ * (b * c) ^ (-2 : ℤ) = 1 :=
-- by group_rel [h]

-- example (h : a * b * a⁻¹ * b ^ (-3 : ℤ) = 1) :
--   a^4 * b * a * b * a⁻¹ * b^(-4 : ℤ) * a^(-3 : ℤ) *
--     b * a⁻¹ * b ^ (-3 : ℤ) = 1 :=
-- by group1r using h

-- example (h : a * b * a⁻¹ * b ^ (-3 : ℤ) = 1) :
--   a^4 * b * a * b * a⁻¹ * b^(-3 : ℤ) * b⁻¹ * a^(-3 : ℤ) *
--     b * a⁻¹ * b ^ (-3 : ℤ) = 1 :=
-- by group_rel [h]

-- example (h : a * b * a⁻¹ * b ^ (-2 : int) = 1) (h1 : b * c * a⁻¹ = 1) :
--   a ^ 2 * b * (a⁻¹)^2 * b * a^2 * b⁻¹ * (a⁻¹)^2 * b⁻¹ = 1 :=
-- by group_rel [h, h1]

-- example (h : (a * c) * b * (a * c)⁻¹ * b ^ (-2 : int) = 1) :
--   (a * c) * b * ((a * c)⁻¹) * b * (a * c) * b⁻¹ * ((a * c)⁻¹) * b⁻¹ = 1 :=
-- by group_rel [h]

-- example (h : (a * c) * b * (a * c)⁻¹ * b ^ (-2 : int) = 1) :
--   (a * c) * b * ((a * c)⁻¹) * b * (a * c) * b⁻¹ * ((a * c)⁻¹) * b⁻¹ = 1 :=
-- by group1r using h

-- example (h : (a * c) * b * (a * c)⁻¹ * b ^ (-2 : int) = 1) :
--   (a * c) ^ 2 * b * ((a * c)⁻¹)^2 * b * (a * c)^2 * b⁻¹ * ((a * c)⁻¹)^2 * b⁻¹ = 1 :=
-- by group_rel [h]

-- example (h : (a * c) * b * (a * c)⁻¹ * b ^ (-2 : int) = 1) :
--   (a * c) ^ 2 * b * ((a * c)⁻¹)^2 * b * (a * c)^2 * b⁻¹ * ((a * c)⁻¹)^2 * b⁻¹ = 1 :=
-- by group1r using h

-- example (h : (a * c) * b * (a * c)⁻¹ * b ^ (-2 : int) = 1) :
--   (a * c) ^ 5 * b * ((a * c)⁻¹)^5 * b * (a * c)^5 * b⁻¹ * ((a * c)⁻¹)^5 * b⁻¹ = 1 :=
-- by group_rel [h]

-- example (h : (a * c) * b * (a * c)⁻¹ * b ^ (-2 : int) = 1) :
--   (a * c) ^ 5 * b * ((a * c)⁻¹)^5 * b * (a * c)^5 * b⁻¹ * ((a * c)⁻¹)^5 * b⁻¹ = 1 :=
-- by group1r using h

-- example (h : (a * c) * b * (a * c)⁻¹ * b⁻¹ = 1) :
--   (a * c)^2 * b^2 * (a * c) ^ (-2 : int) * b ^ (-2 : int) = 1 :=
-- by group_rel [h]

-- example (h : (a * c) * b * (a * c)⁻¹ * b⁻¹ = 1) :
--   (a * c)^2 * b^2 * (a * c) ^ (-2 : int) * b ^ (-2 : int) = 1 :=
-- by group1r using h

-- example (h : (a * c) * b * (a * c)⁻¹ * b⁻¹ = 1) :
--   (a * c)^5 * b^5 * (a * c) ^ (-5 : int) * b ^ (-5 : int) = 1 :=
-- by group_rel [h]

-- example (h : (a * c) * b * (a * c)⁻¹ * b⁻¹ = 1) :
--   (a * c)^5 * b^5 * (a * c) ^ (-5 : int) * b ^ (-5 : int) = 1 :=
-- by group1r using h

-- example (h : (a * c) * b * (a * c)⁻¹ * b⁻¹ = 1) :
--   (a * c)^10 * b^10 * (a * c) ^ (-10 : int) * b ^ (-10 : int) = 1 :=
-- by group_rel [h]

-- example (h : (a * c) * b * (a * c)⁻¹ * b⁻¹ = 1) :
--   (a * c)^10 * b^10 * (a * c) ^ (-10 : int) * b ^ (-10 : int) = 1 :=
-- by group1r using h

-- example (h : a * b * (a^3)⁻¹ * b^4 = 1) :
--   a^2 * b * a * b * a^(-3 : int) * b^3 * a^(-2 : int)
--   * b^(-4 : int) * a^3 * (a * b)⁻¹ = 1 :=
-- by group_rel [h]

-- example (h : a * b * (a^3)⁻¹ * b^4 = 1) :
--   a^2 * b * a * b * a^(-3 : int) * b^3 * a^(-2 : int)
--   * b^(-4 : int) * a^3 * (a * b)⁻¹ = 1 :=
-- by group1r using h

-- example (h : a * b * a⁻¹ * b^(-2 : int) = 1)
--   (h1 : b * a * b⁻¹ * a ^ (-2 : int) = 1) :
--   a = 1 :=
-- by group_rel [h, h1]

example (h1 : a * c * a⁻¹ * c⁻¹ = 1)
        (h2 : c⁻¹ * d * c * d * c⁻¹ * d⁻¹ * c * d⁻¹ = 1)
        (h3 : a * c⁻¹ * d * c * a⁻¹ * c⁻¹ * d⁻¹ * d⁻¹ * c = 1) :
   a * d * a⁻¹ * d⁻¹ * d⁻¹ = 1 :=
by group_rel [h1, h2, h3]


import Smt

example (n m : Int) (h : 0 < m) : n % m < m := by
  smt [h]
  sorry

example (n m k l : Int) : (n - m) * k + l = n*k - m*k + l := by
  smt
  sorry

example (n m k l : Int) (hN : n ≤ m) (hK : k ≤ l) : n + k ≤ m + l := by
  smt [hN, hK]
  sorry


import M4R.Algebra.Ring.Ring
import M4R.Algebra.Ring.SubRing

namespace M4R
  open NCSemiring

  structure SMulMap (α : Type _) (β : Type _) [NCSemiring α] [NCSemiring β] extends α →₊ β where
    preserve_mul : ∀ a b, hom (a * b) = hom a * hom b
  infixr:25 " →* " => SMulMap
  instance SMulMapFun [NCSemiring α] [NCSemiring β] : CoeFun (α →* β) (fun _ => α → β) where
    coe := fun f => f.hom

  structure SHomomorphism (α : Type _) (β : Type _) [NCSemiring α] [NCSemiring β] extends α →* β where
    preserve_one  : hom 1 = 1
  infixr:25 " →*₁ " => SHomomorphism
  instance SHomomorphismFun [NCSemiring α] [NCSemiring β] : CoeFun (α →*₁ β) (fun _ => α → β) where
    coe := fun f => f.hom

  structure SIsomorphism (α : Type _) (β : Type _) [NCSemiring α] [NCSemiring β] extends α →* β, α ≅₊ β
  infixr:25 " ≅* " => SIsomorphism
  instance SIsomorphismFun [NCSemiring α] [NCSemiring β] : CoeFun (α ≅* β) (fun _ => α → β) where
    coe := fun f => f.hom

  structure RMulMap (α : Type _) (β : Type _) [NCRing α] [NCRing β] extends α →* β, α →₋ β
  infixr:25 " →ᵣ " => RMulMap
  instance RMulMapFun  [NCRing α] [NCRing β] : CoeFun (α →ᵣ β) (fun _ => α → β) where
    coe := fun f => f.hom

  structure RHomomorphism (α : Type _) (β : Type _) [NCRing α] [NCRing β] extends α →ᵣ β, α →*₁ β
  infixr:25 " →ᵣ₁ " => RHomomorphism
  instance RHomomorphismFun [NCRing α] [NCRing β] : CoeFun (α →ᵣ₁ β) (fun _ => α → β) where
    coe := fun f => f.hom

  structure RIsomorphism (α : Type _) (β : Type _) [NCRing α] [NCRing β] extends α →ᵣ β, α ≅₊ β
  infixr:25 " ≅ᵣ " => RIsomorphism
  instance RIsomorphismFun [NCRing α] [NCRing β] : CoeFun (α ≅ᵣ β) (fun _ => α → β) where
    coe := fun f => f.hom

  namespace SMulMap
    variable [NCSemiring α] [NCSemiring β] [NCSemiring γ] [NCSemiring δ]

    def kernel (slm : α →* β) : SubMonoid α := slm.toMHomomorphism.kernel

    def image (slm : α →* β) : SubMonoid β := slm.toMHomomorphism.image

    protected def comp (hab : α →* β) (hbc : β →* γ) : α →* γ where
      toMHomomorphism := hab.toMHomomorphism.comp hbc.toMHomomorphism
      preserve_mul    := fun _ _ => by
        simp only [MHomomorphism.comp, Function.comp]
        rw [hab.preserve_mul, hbc.preserve_mul]

    protected def Identity : α →* α where
      toMHomomorphism := MHomomorphism.Identity
      preserve_mul    := fun _ _ => rfl

    protected theorem preserve_one_of_1_in_image {f : α →* β} (h1 : 1 ∈ Function.image f.hom) : f 1 = 1 := by
      let ⟨x, hx⟩ := h1; rw [←hx, ←mul_one x, f.preserve_mul, hx, one_mul]

    protected theorem preserve_one_of_surjective {f : α →* β} (hf : Function.surjective f.hom) : f 1 = 1 :=
      SMulMap.preserve_one_of_1_in_image (hf 1)

    protected theorem preserve_pow_ne_zero (f : α →* β) (x : α) {n : Nat} (hn : n ≠ 0) : f (x ^ n) = f x ^ n := by
      have : ∀ n : Nat, f (x ^ n.succ) = f x ^ n.succ := fun n => by
        induction n with
        | zero      => rw [pow_nat_1, pow_nat_1]
        | succ n ih => rw [pow_nat_succ, f.preserve_mul, ih, ←pow_nat_succ]
      cases n; contradiction; exact this _

    protected def Product (f : α →* γ) (g : β →* δ) : α × β →* γ × δ where
      toMHomomorphism := f.toMHomomorphism.Product g.toMHomomorphism
      preserve_mul    := fun (a₁, b₁) (a₂, b₂) => congr (congrArg Prod.mk (f.preserve_mul a₁ a₂)) (g.preserve_mul b₁ b₂)

    protected noncomputable def MultiProd_cons {ι : Type _} (fι : ι → Type _) [∀ i, NCSemiring (fι i)] {s : Finset ι} {a : ι} (ha : a ∉ s) :
      MultiProd (fun i : s => fι i.val) × fι a →* MultiProd (fun i : s.cons a ha => fι i.val) where
        toMHomomorphism := MHomomorphism.MultiProd_cons fι ha
        preserve_mul    := fun x y => funext fun ⟨i, hi⟩ => by
          simp only [MHomomorphism.MultiProd_cons, multi_product.Mul_def, product_mul]
          byCases h : i = a
          { subst h; simp only [dite_true] }
          { simp only [h, dite_false] }

  end SMulMap

  namespace SHomomorphism
    variable [NCSemiring α] [NCSemiring β] [NCSemiring γ]

    def kernel (sh : α →*₁ β) : SubMonoid α := sh.toSMulMap.kernel

    def image (sh : α →*₁ β) : SubSemiring β where
      toSubMonoid := sh.toSMulMap.image
      has_one     := ⟨1, sh.preserve_one⟩
      mul_closed  := fun _ ⟨a, ha⟩ _ ⟨b, hb⟩ => ⟨a * b, ha ▸ hb ▸ sh.preserve_mul a b⟩

    protected def comp (hab : α →*₁ β) (hbc : β →*₁ γ) : α →*₁ γ where
      toSMulMap    := hab.toSMulMap.comp hbc.toSMulMap
      preserve_one := by
        simp only [SMulMap.comp, MHomomorphism.comp, Function.comp]
        rw [hab.preserve_one, hbc.preserve_one]

    protected def Identity : α →*₁ α where
      toSMulMap    := SMulMap.Identity
      preserve_one := rfl

    protected theorem preserve_pow (f : α →*₁ β) (x : α) : (n : Nat) → f (x ^ n) = f x ^ n
    | 0   => f.preserve_one
    | n+1 => f.preserve_pow_ne_zero x n.succ_ne_zero

  end SHomomorphism

  namespace SIsomorphism
    variable [NCSemiring α] [NCSemiring β] [NCSemiring γ] [NCSemiring δ]

    protected theorem preserve_one (f : α ≅* β) : f 1 = 1 :=
      SMulMap.preserve_one_of_surjective f.toMIsomorphism.to_surjective

    def toSHomomorphism (f : α ≅* β) : α →*₁ β where
      toSMulMap    := f.toSMulMap
      preserve_one := f.preserve_one

    protected def inv_hom (f : α ≅* β) : β →*₁ α where
      toMHomomorphism := f.toMIsomorphism.inv_hom
      preserve_one    := by
        have : f.toMIsomorphism.inv_hom (f 1) = f.inv (f 1)  := rfl
        rw [←f.preserve_one, this, f.left_inv]
      preserve_mul    := fun a b => by
        let ⟨_, ha⟩ := f.right_inv.surjective a
        let ⟨_, hb⟩ := f.right_inv.surjective b
        have : f.toMIsomorphism.inv_hom.hom = f.inv := rfl
        rw [←ha, ←hb, this, ←f.preserve_mul, f.left_inv, f.left_inv, f.left_inv]

    protected def symm (f : α ≅* β) : β ≅* α where
      toSMulMap := f.inv_hom.toSMulMap
      inv       := f
      left_inv  := f.right_inv
      right_inv := f.left_inv

    protected theorem comp (hab : α ≅* β) (hbc : β ≅* γ) : α ≅* γ where
      toSMulMap := hab.toSMulMap.comp hbc.toSMulMap
      inv       := hab.inv ∘ hbc.inv
      left_inv  := fun _ => by
        have : hab.toSMulMap.comp hbc.toSMulMap = hbc.hom ∘ hab.hom := rfl
        rw [this, ←Function.comp_eq, ←Function.comp_eq, hbc.left_inv, hab.left_inv]
      right_inv := fun _ => by
        have : hab.toSMulMap.comp hbc.toSMulMap = hbc.hom ∘ hab.hom := rfl
        rw [this, ←Function.comp_eq, ←Function.comp_eq, hab.right_inv, hbc.right_inv]

    protected noncomputable def of_bijection (f : α →* β) (hf : Function.bijective f.hom) : α ≅* β where
        toSMulMap := f
        inv       := fun b => Classical.choose (hf.surj b)
        left_inv  := fun a => hf.inj (Classical.choose_spec (hf.surj (f a)))
        right_inv := fun a => Classical.choose_spec (hf.surj a)

    protected noncomputable def Identity : α ≅* α :=
      SIsomorphism.of_bijection _ (by apply Function.id_bijective : Function.bijective SHomomorphism.Identity.hom)

    protected def SelfInverse (f : α →* α) (h : ∀ a, f (f a) = a) : α ≅* α where
      toSMulMap := f
      inv       := f.hom
      left_inv  := h
      right_inv := h

    protected def Product (f : α ≅* γ) (g : β ≅* δ) : α × β ≅* γ × δ where
      toSMulMap := f.toSMulMap.Product g.toSMulMap
      inv       := (f.toMIsomorphism.Product g.toMIsomorphism).inv
      left_inv  := (f.toMIsomorphism.Product g.toMIsomorphism).left_inv
      right_inv := (f.toMIsomorphism.Product g.toMIsomorphism).right_inv

    protected noncomputable def MultiProd_cons {ι : Type _} (fι : ι → Type _) [∀ i, NCSemiring (fι i)] {s : Finset ι} {a : ι} (ha : a ∉ s) :
      MultiProd (fun i : s => fι i.val) × fι a ≅* MultiProd (fun i : s.cons a ha => fι i.val) where
        toSMulMap := SMulMap.MultiProd_cons fι ha
        inv       := (MIsomorphism.MultiProd_cons fι ha).inv
        left_inv  := (MIsomorphism.MultiProd_cons fι ha).left_inv
        right_inv := (MIsomorphism.MultiProd_cons fι ha).right_inv

  end SIsomorphism

  namespace RMulMap
    variable [NCRing α] [NCRing β] [NCRing γ] [NCRing δ]

    def kernel (rlm : α →ᵣ β) : SubGroup α := rlm.toGHomomorphism.kernel

    def image (rlm : α →ᵣ β) : SubGroup β := rlm.toGHomomorphism.image

    protected def comp (hab : α →ᵣ β) (hbc : β →ᵣ γ) : α →ᵣ γ where
      toSMulMap    := hab.toSMulMap.comp hbc.toSMulMap
      preserve_neg := (hab.toGHomomorphism.comp hbc.toGHomomorphism).preserve_neg

    protected def Identity : α →ᵣ α where
      toSMulMap    := SMulMap.Identity
      preserve_neg := GHomomorphism.Identity.preserve_neg

    protected theorem preserve_one_of_1_in_image {f : α →ᵣ β} (h1 : 1 ∈ Function.image f.hom) : f 1 = 1 :=
      SMulMap.preserve_one_of_1_in_image h1

    protected theorem preserve_one_of_surjective {f : α →ᵣ β} (hf : Function.surjective f.hom) : f 1 = 1 :=
      SMulMap.preserve_one_of_surjective hf

    protected theorem preserve_pow_ne_zero (f : α →ᵣ β) (x : α) {n : Nat} (hn : n ≠ 0) : f (x ^ n) = f x ^ n :=
      f.toSMulMap.preserve_pow_ne_zero x hn

    protected def Product (f : α →ᵣ γ) (g : β →ᵣ δ) : α × β →ᵣ γ × δ where
      toSMulMap    := f.toSMulMap.Product g.toSMulMap
      preserve_neg := (f.toGHomomorphism.Product g.toGHomomorphism).preserve_neg

    protected noncomputable def MultiProd_cons {ι : Type _} (fι : ι → Type _) [∀ i, NCRing (fι i)] {s : Finset ι} {a : ι} (ha : a ∉ s) :
      MultiProd (fun i : s => fι i.val) × fι a →ᵣ MultiProd (fun i : s.cons a ha => fι i.val) where
        toSMulMap    := SMulMap.MultiProd_cons fι ha
        preserve_neg := (GHomomorphism.MultiProd_cons fι ha).preserve_neg

  end RMulMap

  namespace RHomomorphism
    variable [NCRing α] [NCRing β] [NCRing γ]

    def kernel (rh : α →ᵣ₁ β) : SubGroup α := rh.toRMulMap.kernel

    def image (rh : α →ᵣ₁ β) : SubRing β where
      toSubSemiring := rh.toSHomomorphism.image
      neg_closed    := rh.toGHomomorphism.image.neg_closed

    protected def comp (hab : α →ᵣ₁ β) (hbc : β →ᵣ₁ γ) : α →ᵣ₁ γ where
      toRMulMap    := hab.toRMulMap.comp hbc.toRMulMap
      preserve_one := (hab.toSHomomorphism.comp hbc.toSHomomorphism).preserve_one

    protected def Identity : α →ᵣ₁ α where
      toRMulMap    := RMulMap.Identity
      preserve_one := SHomomorphism.Identity.preserve_one

    protected theorem preserve_pow (f : α →ᵣ₁ β) (x : α) (n : Nat) : f (x ^ n) = f x ^ n :=
      f.toSHomomorphism.preserve_pow x n

  end RHomomorphism

  namespace RIsomorphism
    variable [NCRing α] [NCRing β] [NCRing γ] [NCRing δ]

    protected theorem preserve_one (f : α ≅ᵣ β) : f 1 = 1 :=
      RMulMap.preserve_one_of_surjective f.toMIsomorphism.to_surjective

    def toSHomomorphism (f : α ≅ᵣ β) : α →ᵣ₁ β where
      toRMulMap    := f.toRMulMap
      preserve_one := f.preserve_one

    protected def inv_hom [NCRing α] [NCRing β] (f : α ≅ᵣ β) : β →ᵣ₁ α where
      toMHomomorphism := f.toMIsomorphism.inv_hom
      preserve_neg    := fun a => by
        let ⟨_, ha⟩ := f.right_inv.surjective a
        have : f.toMIsomorphism.inv_hom.hom = f.inv := rfl
        rw [this, ←ha, ←f.preserve_neg, f.left_inv, f.left_inv]
      preserve_one    := by
        have : f.toMIsomorphism.inv_hom (f 1) = f.inv (f 1) := rfl
        simp only; rw [←f.preserve_one, this, f.left_inv]
      preserve_mul    := fun a b => by
        let ⟨_, ha⟩ := f.right_inv.surjective a
        let ⟨_, hb⟩ := f.right_inv.surjective b
        have : f.toMIsomorphism.inv_hom.hom = f.inv := rfl
        rw [←ha, ←hb, this, ←f.preserve_mul, f.left_inv, f.left_inv, f.left_inv]

    protected def symm [NCRing α] [NCRing β] (f : α ≅ᵣ β) : β ≅ᵣ α where
      toRMulMap := f.inv_hom.toRMulMap
      inv       := f
      left_inv  := f.right_inv
      right_inv := f.left_inv

    protected theorem comp [NCRing α] [NCRing β] [NCRing γ] (hab : α ≅ᵣ β) (hbc : β ≅ᵣ γ) : α ≅ᵣ γ where
      toRMulMap := hab.toRMulMap.comp hbc.toRMulMap
      inv       := hab.inv ∘ hbc.inv
      left_inv  := fun _ => by
        have : hab.toRMulMap.comp hbc.toRMulMap = hbc.hom ∘ hab.hom := rfl
        rw [this, ←Function.comp_eq, ←Function.comp_eq, hbc.left_inv, hab.left_inv]
      right_inv := fun _ => by
        have : hab.toRMulMap.comp hbc.toRMulMap = hbc.hom ∘ hab.hom := rfl
        rw [this, ←Function.comp_eq, ←Function.comp_eq, hab.right_inv, hbc.right_inv]

    protected noncomputable def of_bijection [NCRing α] [NCRing β] (f : α →ᵣ β)
      (hf : Function.bijective f.hom) : α ≅ᵣ β where
        toRMulMap := f
        inv       := fun b => Classical.choose (hf.surj b)
        left_inv  := fun a => hf.inj (Classical.choose_spec (hf.surj (f a)))
        right_inv := fun a => Classical.choose_spec (hf.surj a)

    protected noncomputable def Identity [NCRing α] : α ≅ᵣ α :=
      RIsomorphism.of_bijection _ (by apply Function.id_bijective : Function.bijective RHomomorphism.Identity.hom)

    protected def SelfInverse [NCRing α] (f : α →ᵣ α) (h : ∀ a, f (f a) = a) : α ≅ᵣ α where
      toRMulMap := f
      inv       := f.hom
      left_inv  := h
      right_inv := h

    protected def Product (f : α ≅ᵣ γ) (g : β ≅ᵣ δ) : α × β ≅ᵣ γ × δ where
      toRMulMap := f.toRMulMap.Product g.toRMulMap
      inv       := (f.toMIsomorphism.Product g.toMIsomorphism).inv
      left_inv  := (f.toMIsomorphism.Product g.toMIsomorphism).left_inv
      right_inv := (f.toMIsomorphism.Product g.toMIsomorphism).right_inv

    protected noncomputable def MultiProd_cons {ι : Type _} (fι : ι → Type _) [∀ i, NCRing (fι i)] {s : Finset ι} {a : ι} (ha : a ∉ s) :
      MultiProd (fun i : s => fι i.val) × fι a ≅ᵣ MultiProd (fun i : s.cons a ha => fι i.val) where
        toRMulMap := RMulMap.MultiProd_cons fι ha
        inv       := (MIsomorphism.MultiProd_cons fι ha).inv
        left_inv  := (MIsomorphism.MultiProd_cons fι ha).left_inv
        right_inv := (MIsomorphism.MultiProd_cons fι ha).right_inv

  end RIsomorphism

  protected def NCSemiring.MulHomLeft [NCSemiring α] (a : α) : α →₊ α where
    hom           := (a * ·)
    preserve_zero := by simp only [NCSemiring.mul_zero]
    preserve_add  := fun _ _ => by simp only [NCSemiring.mul_distrib_left]

  protected def NCSemiring.MulHomRight [NCSemiring α] (a : α) : α →₊ α where
    hom           := (· * a)
    preserve_zero := by simp only [NCSemiring.zero_mul]
    preserve_add  := fun _ _ => by simp only [NCSemiring.mul_distrib_right]

  protected def NCRing.MulHomLeft [NCRing α] (a : α) : α →₋ α where
    toMHomomorphism := NCSemiring.MulHomLeft a
    preserve_neg    := fun _ => by simp only [NCSemiring.MulHomLeft, NCRing.mul_neg]

  protected def NCRing.MulHomRight [NCRing α] (a : α) : α →₋ α where
    toMHomomorphism := NCSemiring.MulHomRight a
    preserve_neg    := fun _ => by simp only [NCSemiring.MulHomRight, NCRing.neg_mul]

end M4R


import pq_to_group

import group_theory.free_group
import group_theory.quotient_group

universe u

section pq_group_free_quotient

variables {s : Type u}

inductive pq_group_relation_space_rel : free_group s → Prop
| rhd_rel (a b c : s) : pq_group_relation_space_rel (free_group.of a * free_group.of b * (free_group.of a)⁻¹ * (free_group.of c)⁻¹)
| pow_rel (a b : s) (n : ℤ) : pq_group_relation_space_rel ((free_group.of a) ^ n * (free_group.of b)⁻¹)
| one_closed : pq_group_relation_space_rel 1
| mul_closed (x y : free_group s) (hx : pq_group_relation_space_rel x) (hy : pq_group_relation_space_rel y) : pq_group_relation_space_rel (x * y)
| inv_closed (x : free_group s) (hx : pq_group_relation_space_rel x) : pq_group_relation_space_rel (x⁻¹)
| normal_closed (x y : free_group s) (hx : pq_group_relation_space_rel x) : pq_group_relation_space_rel (y * x * y⁻¹)

def pq_group_relation_space : subgroup (free_group s) := {
  carrier := pq_group_relation_space_rel,
  one_mem' := pq_group_relation_space_rel.one_closed,
  mul_mem' := pq_group_relation_space_rel.mul_closed,
  inv_mem' := pq_group_relation_space_rel.inv_closed }

instance pq_group_relation_space_is_normal : (@pq_group_relation_space s).normal :=
begin
  fconstructor,
  intros x hx y,
  apply pq_group_relation_space_rel.normal_closed,
  apply hx,
end

lemma free_of_in_pq_group_relation_space (a : s) : free_group.of a ∈ (@pq_group_relation_space s) :=
begin
  suffices : free_group.of a = (free_group.of a * free_group.of a * (free_group.of a)⁻¹ * (free_group.of a)⁻¹) * ((free_group.of a) ^ (2 : ℤ) * (free_group.of a)⁻¹),
  {
    rw this,
    clear this,
    apply subgroup.mul_mem,
    apply pq_group_relation_space_rel.rhd_rel,
    apply pq_group_relation_space_rel.pow_rel,
  },
  group,
end

lemma pq_group_relation_space_is_univ : (@pq_group_relation_space s) = ⊤ :=
begin
  ext1,
  simp only [subgroup.mem_top, iff_true],
  apply free_group.induction_on x;
  clear x,
  {
    apply subgroup.one_mem,
  },
  {
    apply free_of_in_pq_group_relation_space,
  },
  {
    intro x,
    apply subgroup.inv_mem,
  },
  {
    apply subgroup.mul_mem,
  },
end

-- This is not true!!! Everything going forward is useless

variables {R : subgroup (free_group s)} [hR : R.normal]
include hR

instance rel_intersection_is_normal : (R ⊓ pq_group_relation_space).normal :=
begin
  fconstructor,
  intros n hn g,
  cases hn with hn1 hn2,
  split,
  apply hR.conj_mem, assumption,
  apply pq_group_relation_space_is_normal.conj_mem, assumption,
end

def pq_group_free_quotient_iso_rel_intersect_forward : pq_group (quotient_group.quotient R) →* quotient_group.quotient (R ⊓ pq_group_relation_space) :=
begin
  fapply pq_morph_to_L_morph_adj,
  {
    intro x,
    induction x,
    {
      exact quotient_group.mk x,
    },
    {
      simp only [eq_rec_constant],
      apply quotient.sound,
      show x_a⁻¹ * x_b ∈ (R ⊓ pq_group_relation_space),
      have hx : x_a⁻¹ * x_b ∈ R := x_p,
      sorry,
    },
  },
  sorry,
end

def pq_group_free_quotient_iso_rel_intersect : pq_group (quotient_group.quotient R) ≃* quotient_group.quotient (R ⊓ pq_group_relation_space) := {
  to_fun := sorry,
  inv_fun := sorry,
  left_inv := sorry,
  right_inv := sorry,
  map_mul' := sorry }

end pq_group_free_quotient


import Smt

theorem trans (p q r : Prop) : p = q → q = r → p = r := by
  smt