/-
Copyright (c) 2020 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import ring_theory.localization
import ring_theory.ideal.over
import ring_theory.jacobson_ideal

/-!
# Jacobson Rings
The following conditions are equivalent for a ring `R`:
1. Every radical ideal `I` is equal to its Jacobson radical
2. Every radical ideal `I` can be written as an intersection of maximal ideals
3. Every prime ideal `I` is equal to its Jacobson radical
Any ring satisfying any of these equivalent conditions is said to be Jacobson.
Some particular examples of Jacobson rings are also proven.
`is_jacobson_quotient` says that the quotient of a Jacobson ring is Jacobson.
`is_jacobson_localization` says the localization of a Jacobson ring to a single element is Jacobson.
`is_jacobson_polynomial_iff_is_jacobson` says polynomials over a Jacobson ring form a Jacobson ring.
## Main definitions
Let `R` be a commutative ring. Jacobson Rings are defined using the first of the above conditions
* `is_jacobson R` is the proposition that `R` is a Jacobson ring. It is a class,
  implemented as the predicate that for any ideal, `I.radical = I` implies `I.jacobson = I`.

## Main statements
* `is_jacobson_iff_prime_eq` is the equivalence between conditions 1 and 3 above.
* `is_jacobson_iff_Inf_maximal` is the equivalence between conditions 1 and 2 above.
* `is_jacobson_of_surjective` says that if `R` is a Jacobson ring and `f : R →+* S` is surjective,
  then `S` is also a Jacobson ring
* `is_jacobson_mv_polynomial` says that multi-variate polynomials over a Jacobson ring are Jacobson.
## Tags
Jacobson, Jacobson Ring
-/

namespace ideal

open polynomial

section is_jacobson
variables {R S : Type*} [comm_ring R] [comm_ring S] {I : ideal R}

/-- A ring is a Jacobson ring if for every radical ideal `I`,
 the Jacobson radical of `I` is equal to `I`.
 See `is_jacobson_iff_prime_eq` and `is_jacobson_iff_Inf_maximal` for equivalent definitions. -/
class is_jacobson (R : Type*) [comm_ring R] : Prop :=
(out' : ∀ (I : ideal R), I.radical = I → I.jacobson = I)

theorem is_jacobson_iff {R} [comm_ring R] :
  is_jacobson R ↔ ∀ (I : ideal R), I.radical = I → I.jacobson = I :=
⟨λ h, h.1, λ h, ⟨h⟩⟩

theorem is_jacobson.out {R} [comm_ring R] :
  is_jacobson R → ∀ {I : ideal R}, I.radical = I → I.jacobson = I := is_jacobson_iff.1

/--  A ring is a Jacobson ring if and only if for all prime ideals `P`,
 the Jacobson radical of `P` is equal to `P`. -/
lemma is_jacobson_iff_prime_eq : is_jacobson R ↔ ∀ P : ideal R, is_prime P → P.jacobson = P :=
begin
  refine is_jacobson_iff.trans ⟨λ h I hI, h I (is_prime.radical hI), _⟩,
  refine λ h I hI, le_antisymm (λ x hx, _) (λ x hx, mem_Inf.mpr (λ _ hJ, hJ.left hx)),
  rw [← hI, radical_eq_Inf I, mem_Inf],
  intros P hP,
  rw set.mem_set_of_eq at hP,
  erw mem_Inf at hx,
  erw [← h P hP.right, mem_Inf],
  exact λ J hJ, hx ⟨le_trans hP.left hJ.left, hJ.right⟩
end

/-- A ring `R` is Jacobson if and only if for every prime ideal `I`,
 `I` can be written as the infimum of some collection of maximal ideals.
 Allowing ⊤ in the set `M` of maximal ideals is equivalent, but makes some proofs cleaner. -/
lemma is_jacobson_iff_Inf_maximal : is_jacobson R ↔
  ∀ {I : ideal R}, I.is_prime → ∃ M : set (ideal R), (∀ J ∈ M, is_maximal J ∨ J = ⊤) ∧ I = Inf M :=
⟨λ H I h, eq_jacobson_iff_Inf_maximal.1 (H.out (is_prime.radical h)),
  λ H, is_jacobson_iff_prime_eq.2 (λ P hP, eq_jacobson_iff_Inf_maximal.2 (H hP))⟩

lemma is_jacobson_iff_Inf_maximal' : is_jacobson R ↔
  ∀ {I : ideal R}, I.is_prime → ∃ M : set (ideal R),
  (∀ (J ∈ M) (K : ideal R), J < K → K = ⊤) ∧ I = Inf M :=
⟨λ H I h, eq_jacobson_iff_Inf_maximal'.1 (H.out (is_prime.radical h)),
  λ H, is_jacobson_iff_prime_eq.2 (λ P hP, eq_jacobson_iff_Inf_maximal'.2 (H hP))⟩

lemma radical_eq_jacobson [H : is_jacobson R] (I : ideal R) : I.radical = I.jacobson :=
le_antisymm (le_Inf (λ J ⟨hJ, hJ_max⟩, (is_prime.radical_le_iff hJ_max.is_prime).mpr hJ))
            ((H.out (radical_idem I)) ▸ (jacobson_mono le_radical))

/-- Fields have only two ideals, and the condition holds for both of them.  -/
@[priority 100]
instance is_jacobson_field {K : Type*} [field K] : is_jacobson K :=
⟨λ I hI, or.rec_on (eq_bot_or_top I)
(λ h, le_antisymm
  (Inf_le ⟨le_of_eq rfl, (eq.symm h) ▸ bot_is_maximal⟩)
  ((eq.symm h) ▸ bot_le))
(λ h, by rw [h, jacobson_eq_top_iff])⟩

theorem is_jacobson_of_surjective [H : is_jacobson R] :
  (∃ (f : R →+* S), function.surjective f) → is_jacobson S :=
begin
  rintros ⟨f, hf⟩,
  rw is_jacobson_iff_Inf_maximal,
  intros p hp,
  use map f '' {J : ideal R | comap f p ≤ J ∧ J.is_maximal },
  use λ j ⟨J, hJ, hmap⟩, hmap ▸ or.symm (map_eq_top_or_is_maximal_of_surjective f hf hJ.right),
  have : p = map f ((comap f p).jacobson),
  from (is_jacobson.out' (comap f p) (by rw [← comap_radical, is_prime.radical hp])).symm
    ▸ (map_comap_of_surjective f hf p).symm,
  exact eq.trans this (map_Inf hf (λ J ⟨hJ, _⟩, le_trans (ideal.ker_le_comap f) hJ)),
end

@[priority 100]
instance is_jacobson_quotient [is_jacobson R] : is_jacobson (R ⧸ I) :=
is_jacobson_of_surjective ⟨quotient.mk I, (by rintro ⟨x⟩; use x; refl)⟩

lemma is_jacobson_iso (e : R ≃+* S) : is_jacobson R ↔ is_jacobson S :=
⟨λ h, @is_jacobson_of_surjective _ _ _ _ h ⟨(e : R →+* S), e.surjective⟩,
  λ h, @is_jacobson_of_surjective _ _ _ _ h ⟨(e.symm : S →+* R), e.symm.surjective⟩⟩

lemma is_jacobson_of_is_integral [algebra R S] (hRS : algebra.is_integral R S)
  (hR : is_jacobson R) : is_jacobson S :=
begin
  rw is_jacobson_iff_prime_eq,
  introsI P hP,
  by_cases hP_top : comap (algebra_map R S) P = ⊤,
  { simp [comap_eq_top_iff.1 hP_top] },
  { haveI : nontrivial (R ⧸ comap (algebra_map R S) P) := quotient.nontrivial hP_top,
    rw jacobson_eq_iff_jacobson_quotient_eq_bot,
    refine eq_bot_of_comap_eq_bot (is_integral_quotient_of_is_integral hRS) _,
    rw [eq_bot_iff, ← jacobson_eq_iff_jacobson_quotient_eq_bot.1 ((is_jacobson_iff_prime_eq.1 hR)
      (comap (algebra_map R S) P) (comap_is_prime _ _)), comap_jacobson],
    refine Inf_le_Inf (λ J hJ, _),
    simp only [true_and, set.mem_image, bot_le, set.mem_set_of_eq],
    haveI : J.is_maximal, { simpa using hJ },
    exact exists_ideal_over_maximal_of_is_integral (is_integral_quotient_of_is_integral hRS) J
      (comap_bot_le_of_injective _ algebra_map_quotient_injective) }
end

lemma is_jacobson_of_is_integral' (f : R →+* S) (hf : f.is_integral)
  (hR : is_jacobson R) : is_jacobson S :=
@is_jacobson_of_is_integral _ _ _ _ f.to_algebra hf hR

end is_jacobson

section localization
open is_localization submonoid
variables {R S : Type*} [comm_ring R] [comm_ring S] {I : ideal R}
variables (y : R) [algebra R S] [is_localization.away y S]

lemma disjoint_powers_iff_not_mem (hI : I.radical = I) :
  disjoint ((submonoid.powers y) : set R) ↑I ↔ y ∉ I.1 :=
begin
  refine ⟨λ h, set.disjoint_left.1 h (mem_powers _), λ h, (disjoint_iff).mpr (eq_bot_iff.mpr _)⟩,
  rintros x ⟨⟨n, rfl⟩, hx'⟩,
  rw [← hI] at hx',
  exact absurd (hI ▸ mem_radical_of_pow_mem hx' : y ∈ I.carrier) h
end

variables (S)

/-- If `R` is a Jacobson ring, then maximal ideals in the localization at `y`
correspond to maximal ideals in the original ring `R` that don't contain `y`.
This lemma gives the correspondence in the particular case of an ideal and its comap.
See `le_rel_iso_of_maximal` for the more general relation isomorphism -/
lemma is_maximal_iff_is_maximal_disjoint [H : is_jacobson R] (J : ideal S) :
  J.is_maximal ↔ (comap (algebra_map R S) J).is_maximal ∧ y ∉ ideal.comap (algebra_map R S) J :=
begin
  split,
  { refine λ h, ⟨_, λ hy, h.ne_top (ideal.eq_top_of_is_unit_mem _ hy
      (map_units _ ⟨y, submonoid.mem_powers _⟩))⟩,
    have hJ : J.is_prime := is_maximal.is_prime h,
    rw is_prime_iff_is_prime_disjoint (submonoid.powers y) at hJ,
    have : y ∉ (comap (algebra_map R S) J).1 :=
      set.disjoint_left.1 hJ.right (submonoid.mem_powers _),
    erw [← H.out (is_prime.radical hJ.left), mem_Inf] at this,
    push_neg at this,
    rcases this with ⟨I, hI, hI'⟩,
    convert hI.right,
    by_cases hJ : J = map (algebra_map R S) I,
    { rw [hJ, comap_map_of_is_prime_disjoint (powers y) S I (is_maximal.is_prime hI.right)],
      rwa disjoint_powers_iff_not_mem y (is_maximal.is_prime hI.right).radical },
    { have hI_p : (map (algebra_map R S) I).is_prime,
      { refine is_prime_of_is_prime_disjoint (powers y) _ I hI.right.is_prime _,
        rwa disjoint_powers_iff_not_mem y (is_maximal.is_prime hI.right).radical },
      have : J ≤ map (algebra_map R S) I :=
        (map_comap (submonoid.powers y) S J) ▸ (map_mono hI.left),
      exact absurd (h.1.2 _ (lt_of_le_of_ne this hJ)) hI_p.1 } },
  { refine λ h, ⟨⟨λ hJ, h.1.ne_top (eq_top_iff.2 _), λ I hI, _⟩⟩,
    { rwa [eq_top_iff, ← (is_localization.order_embedding (powers y) S).le_iff_le] at hJ },
    { have := congr_arg (map (algebra_map R S)) (h.1.1.2 _ ⟨comap_mono (le_of_lt hI), _⟩),
      rwa [map_comap (powers y) S I, map_top] at this,
      refine λ hI', hI.right _,
      rw [← map_comap (powers y) S I, ← map_comap (powers y) S J],
      exact map_mono hI' } }
end

variables {S}

/-- If `R` is a Jacobson ring, then maximal ideals in the localization at `y`
correspond to maximal ideals in the original ring `R` that don't contain `y`.
This lemma gives the correspondence in the particular case of an ideal and its map.
See `le_rel_iso_of_maximal` for the more general statement, and the reverse of this implication -/
lemma is_maximal_of_is_maximal_disjoint [is_jacobson R] (I : ideal R) (hI : I.is_maximal)
  (hy : y ∉ I) : (map (algebra_map R S) I).is_maximal :=
begin
  rw [is_maximal_iff_is_maximal_disjoint S y,
    comap_map_of_is_prime_disjoint (powers y) S I (is_maximal.is_prime hI)
    ((disjoint_powers_iff_not_mem y (is_maximal.is_prime hI).radical).2 hy)],
  exact ⟨hI, hy⟩
end

/-- If `R` is a Jacobson ring, then maximal ideals in the localization at `y`
correspond to maximal ideals in the original ring `R` that don't contain `y` -/
def order_iso_of_maximal [is_jacobson R] :
  {p : ideal S // p.is_maximal} ≃o {p : ideal R // p.is_maximal ∧ y ∉ p} :=
{ to_fun := λ p,
    ⟨ideal.comap (algebra_map R S) p.1, (is_maximal_iff_is_maximal_disjoint S y p.1).1 p.2⟩,
  inv_fun := λ p,
    ⟨ideal.map (algebra_map R S) p.1, is_maximal_of_is_maximal_disjoint y p.1 p.2.1 p.2.2⟩,
  left_inv := λ J, subtype.eq (map_comap (powers y) S J),
  right_inv := λ I, subtype.eq (comap_map_of_is_prime_disjoint _ _ I.1 (is_maximal.is_prime I.2.1)
    ((disjoint_powers_iff_not_mem y I.2.1.is_prime.radical).2 I.2.2)),
  map_rel_iff' := λ I I', ⟨λ h, (show I.val ≤ I'.val,
    from (map_comap (powers y) S I.val) ▸ (map_comap (powers y) S I'.val) ▸ (ideal.map_mono h)),
    λ h x hx, h hx⟩ }

include y

/-- If `S` is the localization of the Jacobson ring `R` at the submonoid generated by `y : R`, then
`S` is Jacobson. -/
lemma is_jacobson_localization [H : is_jacobson R] : is_jacobson S :=
begin
  rw is_jacobson_iff_prime_eq,
  refine λ P' hP', le_antisymm _ le_jacobson,
  obtain ⟨hP', hPM⟩ := (is_localization.is_prime_iff_is_prime_disjoint (powers y) S P').mp hP',
  have hP := H.out (is_prime.radical hP'),
  refine (le_of_eq (is_localization.map_comap (powers y) S P'.jacobson).symm).trans
    ((map_mono _).trans (le_of_eq (is_localization.map_comap (powers y) S P'))),
  have : Inf { I : ideal R | comap (algebra_map R S) P' ≤ I ∧ I.is_maximal ∧ y ∉ I } ≤
    comap (algebra_map R S) P',
  { intros x hx,
    have hxy : x * y ∈ (comap (algebra_map R S) P').jacobson,
    { rw [ideal.jacobson, mem_Inf],
      intros J hJ,
      by_cases y ∈ J,
      { exact J.smul_mem x h },
      { exact (mul_comm y x) ▸ J.smul_mem y ((mem_Inf.1 hx) ⟨hJ.left, ⟨hJ.right, h⟩⟩) } },
    rw hP at hxy,
    cases hP'.mem_or_mem hxy with hxy hxy,
    { exact hxy },
    { exact (hPM ⟨submonoid.mem_powers _, hxy⟩).elim } },
  refine le_trans _ this,
  rw [ideal.jacobson, comap_Inf', Inf_eq_infi],
  refine infi_le_infi_of_subset (λ I hI, ⟨map (algebra_map R S) I, ⟨_, _⟩⟩),
  { exact ⟨le_trans (le_of_eq ((is_localization.map_comap (powers y) S P').symm)) (map_mono hI.1),
    is_maximal_of_is_maximal_disjoint y _ hI.2.1 hI.2.2⟩ },
  { exact is_localization.comap_map_of_is_prime_disjoint _ S I (is_maximal.is_prime hI.2.1)
    ((disjoint_powers_iff_not_mem y hI.2.1.is_prime.radical).2 hI.2.2) }
end

end localization

namespace polynomial
open polynomial

section comm_ring
variables {R S : Type*} [comm_ring R] [comm_ring S] [is_domain S]
variables {Rₘ Sₘ : Type*} [comm_ring Rₘ] [comm_ring Sₘ]

/-- If `I` is a prime ideal of `polynomial R` and `pX ∈ I` is a non-constant polynomial,
  then the map `R →+* R[x]/I` descends to an integral map when localizing at `pX.leading_coeff`.
  In particular `X` is integral because it satisfies `pX`, and constants are trivially integral,
  so integrality of the entire extension follows by closure under addition and multiplication. -/
lemma is_integral_is_localization_polynomial_quotient
  (P : ideal (polynomial R)) (pX : polynomial R) (hpX : pX ∈ P)
  [algebra (R ⧸ P.comap (C : R →+* _)) Rₘ]
  [is_localization.away (pX.map (quotient.mk (P.comap C))).leading_coeff Rₘ]
  [algebra (polynomial R ⧸ P) Sₘ]
  [is_localization ((submonoid.powers (pX.map (quotient.mk (P.comap C))).leading_coeff).map
    (quotient_map P C le_rfl) : submonoid (polynomial R ⧸ P)) Sₘ] :
  (is_localization.map Sₘ (quotient_map P C le_rfl)
    ((submonoid.powers (pX.map (quotient.mk (P.comap C))).leading_coeff).le_comap_map) : Rₘ →+* _)
    .is_integral :=
begin
  let P' : ideal R := P.comap C,
  let M : submonoid (R ⧸ P') :=
  submonoid.powers (pX.map (quotient.mk (P.comap C))).leading_coeff,
  let M' : submonoid (polynomial R ⧸ P) :=
  (submonoid.powers (pX.map (quotient.mk (P.comap C))).leading_coeff).map (quotient_map P C le_rfl),
  let φ : R ⧸ P' →+* polynomial R ⧸ P := quotient_map P C le_rfl,
  let φ' := is_localization.map Sₘ φ M.le_comap_map,
  have hφ' : φ.comp (quotient.mk P') = (quotient.mk P).comp C := rfl,
  intro p,
  obtain ⟨⟨p', ⟨q, hq⟩⟩, hp⟩ := is_localization.surj M' p,
  suffices : φ'.is_integral_elem (algebra_map _ _ p'),
  { obtain ⟨q', hq', rfl⟩ := hq,
    obtain ⟨q'', hq''⟩ := is_unit_iff_exists_inv'.1 (is_localization.map_units Rₘ (⟨q', hq'⟩ : M)),
    refine φ'.is_integral_of_is_integral_mul_unit p (algebra_map _ _ (φ q')) q'' _ (hp.symm ▸ this),
    convert trans (trans (φ'.map_mul _ _).symm (congr_arg φ' hq'')) φ'.map_one using 2,
    rw [← φ'.comp_apply, is_localization.map_comp, ring_hom.comp_apply, subtype.coe_mk] },
  refine is_integral_of_mem_closure''
    (((algebra_map _ Sₘ).comp (quotient.mk P)) '' (insert X {p | p.degree ≤ 0})) _ _ _,
  { rintros x ⟨p, hp, rfl⟩,
    refine hp.rec_on (λ hy, _) (λ hy, _),
    { refine hy.symm ▸ (φ.is_integral_elem_localization_at_leading_coeff ((quotient.mk P) X)
        (pX.map (quotient.mk P')) _ M ⟨1, pow_one _⟩),
      rwa [eval₂_map, hφ', ← hom_eval₂, quotient.eq_zero_iff_mem, eval₂_C_X] },
    { rw [set.mem_set_of_eq, degree_le_zero_iff] at hy,
      refine hy.symm ▸ ⟨X - C (algebra_map _ _ ((quotient.mk P') (p.coeff 0))), monic_X_sub_C _, _⟩,
      simp only [eval₂_sub, eval₂_C, eval₂_X],
      rw [sub_eq_zero, ← φ'.comp_apply, is_localization.map_comp],
      refl } },
  { obtain ⟨p, rfl⟩ := quotient.mk_surjective p',
    refine polynomial.induction_on p
      (λ r, subring.subset_closure $ set.mem_image_of_mem _ (or.inr degree_C_le))
      (λ _ _ h1 h2, _) (λ n _ hr, _),
    { convert subring.add_mem _ h1 h2,
      rw [ring_hom.map_add, ring_hom.map_add] },
    { rw [pow_succ X n, mul_comm X, ← mul_assoc, ring_hom.map_mul, ring_hom.map_mul],
      exact subring.mul_mem _ hr (subring.subset_closure (set.mem_image_of_mem _ (or.inl rfl))) } },
end

/-- If `f : R → S` descends to an integral map in the localization at `x`,
  and `R` is a Jacobson ring, then the intersection of all maximal ideals in `S` is trivial -/
lemma jacobson_bot_of_integral_localization
  {R : Type*} [comm_ring R] [is_domain R] [is_jacobson R]
  (Rₘ Sₘ : Type*) [comm_ring Rₘ] [comm_ring Sₘ]
  (φ : R →+* S) (hφ : function.injective φ) (x : R) (hx : x ≠ 0)
  [algebra R Rₘ] [is_localization.away x Rₘ]
  [algebra S Sₘ] [is_localization ((submonoid.powers x).map φ : submonoid S) Sₘ]
  (hφ' : ring_hom.is_integral
    (is_localization.map Sₘ φ (submonoid.powers x).le_comap_map : Rₘ →+* Sₘ)) :
  (⊥ : ideal S).jacobson = (⊥ : ideal S) :=
begin
  have hM : ((submonoid.powers x).map φ : submonoid S) ≤ non_zero_divisors S :=
    φ.map_le_non_zero_divisors_of_injective hφ (powers_le_non_zero_divisors_of_no_zero_divisors hx),
  letI : is_domain Sₘ := is_localization.is_domain_of_le_non_zero_divisors _ hM,
  let φ' : Rₘ →+* Sₘ := is_localization.map _ φ (submonoid.powers x).le_comap_map,
  suffices : ∀ I : ideal Sₘ, I.is_maximal → (I.comap (algebra_map S Sₘ)).is_maximal,
  { have hϕ' : comap (algebra_map S Sₘ) (⊥ : ideal Sₘ) = (⊥ : ideal S),
    { rw [← ring_hom.ker_eq_comap_bot, ← ring_hom.injective_iff_ker_eq_bot],
      exact is_localization.injective Sₘ hM },
    have hSₘ : is_jacobson Sₘ := is_jacobson_of_is_integral' φ' hφ' (is_jacobson_localization x),
    refine eq_bot_iff.mpr (le_trans _ (le_of_eq hϕ')),
    rw [← hSₘ.out radical_bot_of_is_domain, comap_jacobson],
    exact Inf_le_Inf (λ j hj, ⟨bot_le, let ⟨J, hJ⟩ := hj in hJ.2 ▸ this J hJ.1.2⟩) },
  introsI I hI,
  -- Remainder of the proof is pulling and pushing ideals around the square and the quotient square
  haveI : (I.comap (algebra_map S Sₘ)).is_prime := comap_is_prime _ I,
  haveI : (I.comap φ').is_prime := comap_is_prime φ' I,
  haveI : (⊥ : ideal (S ⧸ I.comap (algebra_map S Sₘ))).is_prime := bot_prime,
  have hcomm: φ'.comp (algebra_map R Rₘ) = (algebra_map S Sₘ).comp φ := is_localization.map_comp _,
  let f := quotient_map (I.comap (algebra_map S Sₘ)) φ le_rfl,
  let g := quotient_map I (algebra_map S Sₘ) le_rfl,
  have := is_maximal_comap_of_is_integral_of_is_maximal' φ' hφ' I
    (by convert hI; casesI _inst_4; refl),
  have := ((is_maximal_iff_is_maximal_disjoint Rₘ x _).1 this).left,
  have : ((I.comap (algebra_map S Sₘ)).comap φ).is_maximal,
  { rwa [comap_comap, hcomm, ← comap_comap] at this },
  rw ← bot_quotient_is_maximal_iff at this ⊢,
  refine is_maximal_of_is_integral_of_is_maximal_comap' f _ ⊥
    ((eq_bot_iff.2 (comap_bot_le_of_injective f quotient_map_injective)).symm ▸ this),
  exact f.is_integral_tower_bot_of_is_integral g quotient_map_injective
    ((comp_quotient_map_eq_of_comp_eq hcomm I).symm ▸
    (ring_hom.is_integral_trans _ _ (ring_hom.is_integral_of_surjective _
      (is_localization.surjective_quotient_map_of_maximal_of_localization (submonoid.powers x) Rₘ
      (by rwa [comap_comap, hcomm, ← bot_quotient_is_maximal_iff])))
      (ring_hom.is_integral_quotient_of_is_integral _ hφ'))),
end

/-- Used to bootstrap the proof of `is_jacobson_polynomial_iff_is_jacobson`.
  That theorem is more general and should be used instead of this one. -/
private lemma is_jacobson_polynomial_of_domain
  (R : Type*) [comm_ring R] [is_domain R] [hR : is_jacobson R]
  (P : ideal (polynomial R)) [is_prime P] (hP : ∀ (x : R), C x ∈ P → x = 0) :
  P.jacobson = P :=
begin
  by_cases Pb : P = ⊥,
  { exact Pb.symm ▸ jacobson_bot_polynomial_of_jacobson_bot
      (hR.out radical_bot_of_is_domain) },
  { rw jacobson_eq_iff_jacobson_quotient_eq_bot,
    haveI : (P.comap (C : R →+* polynomial R)).is_prime := comap_is_prime C P,
    obtain ⟨p, pP, p0⟩ := exists_nonzero_mem_of_ne_bot Pb hP,
    let x := (polynomial.map (quotient.mk (comap (C : R →+* _) P)) p).leading_coeff,
    have hx : x ≠ 0 := by rwa [ne.def, leading_coeff_eq_zero],
    refine jacobson_bot_of_integral_localization
      (localization.away x)
      (localization ((submonoid.powers x).map (P.quotient_map C le_rfl) :
        submonoid (polynomial R ⧸ P)))
      (quotient_map P C le_rfl) quotient_map_injective
      x hx
      _,
    -- `convert` is noticeably faster than `exact` here:
    convert is_integral_is_localization_polynomial_quotient P p pP }
end

lemma is_jacobson_polynomial_of_is_jacobson (hR : is_jacobson R) :
  is_jacobson (polynomial R) :=
begin
  refine is_jacobson_iff_prime_eq.mpr (λ I, _),
  introI hI,
  let R' : subring (polynomial R ⧸ I) := ((quotient.mk I).comp C).range,
  let i : R →+* R' := ((quotient.mk I).comp C).range_restrict,
  have hi : function.surjective (i : R → R') := ((quotient.mk I).comp C).range_restrict_surjective,
  have hi' : (polynomial.map_ring_hom i : polynomial R →+* polynomial R').ker ≤ I,
  { refine λ f hf, polynomial_mem_ideal_of_coeff_mem_ideal I f (λ n, _),
    replace hf := congr_arg (λ (g : polynomial (((quotient.mk I).comp C).range)), g.coeff n) hf,
    change (polynomial.map ((quotient.mk I).comp C).range_restrict f).coeff n = 0 at hf,
    rw [coeff_map, subtype.ext_iff] at hf,
    rwa [mem_comap, ← quotient.eq_zero_iff_mem, ← ring_hom.comp_apply], },
  haveI : (ideal.map (map_ring_hom i) I).is_prime :=
    map_is_prime_of_surjective (map_surjective i hi) hi',
  suffices : (I.map (polynomial.map_ring_hom i)).jacobson = (I.map (polynomial.map_ring_hom i)),
  { replace this := congr_arg (comap (polynomial.map_ring_hom i)) this,
    rw [← map_jacobson_of_surjective _ hi',
      comap_map_of_surjective _ _, comap_map_of_surjective _ _] at this,
    refine le_antisymm (le_trans (le_sup_of_le_left le_rfl)
      (le_trans (le_of_eq this) (sup_le le_rfl hi'))) le_jacobson,
    all_goals {exact polynomial.map_surjective i hi} },
  exact @is_jacobson_polynomial_of_domain R' _ _ (is_jacobson_of_surjective ⟨i, hi⟩)
    (map (map_ring_hom i) I) _ (eq_zero_of_polynomial_mem_map_range I),
end

theorem is_jacobson_polynomial_iff_is_jacobson :
  is_jacobson (polynomial R) ↔ is_jacobson R :=
begin
  refine ⟨_, is_jacobson_polynomial_of_is_jacobson⟩,
  introI H,
  exact is_jacobson_of_surjective ⟨eval₂_ring_hom (ring_hom.id _) 1, λ x,
    ⟨C x, by simp only [coe_eval₂_ring_hom, ring_hom.id_apply, eval₂_C]⟩⟩,
end

instance [is_jacobson R] : is_jacobson (polynomial R) :=
is_jacobson_polynomial_iff_is_jacobson.mpr ‹is_jacobson R›

end comm_ring

section
variables {R : Type*} [comm_ring R] [is_jacobson R]
variables (P : ideal (polynomial R)) [hP : P.is_maximal]

include P hP

lemma is_maximal_comap_C_of_is_maximal [nontrivial R] (hP' : ∀ (x : R), C x ∈ P → x = 0) :
  is_maximal (comap C P : ideal R) :=
begin
  haveI hp'_prime : (P.comap C : ideal R).is_prime := comap_is_prime C P,
  obtain ⟨m, hm⟩ := submodule.nonzero_mem_of_bot_lt (bot_lt_of_maximal P polynomial_not_is_field),
  have : (m : polynomial R) ≠ 0, rwa [ne.def, submodule.coe_eq_zero],
  let φ : R ⧸ P.comap C →+* polynomial R ⧸ P := quotient_map P C le_rfl,
  let M : submonoid (R ⧸ P.comap C) :=
    submonoid.powers ((m : polynomial R).map (quotient.mk (P.comap C : ideal R))).leading_coeff,
  rw ← bot_quotient_is_maximal_iff,
  have hp0 : ((m : polynomial R).map (quotient.mk (P.comap C : ideal R))).leading_coeff ≠ 0 :=
    λ hp0', this $ map_injective (quotient.mk (P.comap C : ideal R))
      ((quotient.mk (P.comap C : ideal R)).injective_iff.2 (λ x hx,
      by rwa [quotient.eq_zero_iff_mem, (by rwa eq_bot_iff : (P.comap C : ideal R) = ⊥)] at hx))
      (by simpa only [leading_coeff_eq_zero, polynomial.map_zero] using hp0'),
  have hM : (0 : R ⧸ P.comap C) ∉ M := λ ⟨n, hn⟩, hp0 (pow_eq_zero hn),
  suffices : (⊥ : ideal (localization M)).is_maximal,
  { rw ← is_localization.comap_map_of_is_prime_disjoint M (localization M) ⊥ bot_prime
        (λ x hx, hM (hx.2 ▸ hx.1)),
    refine ((is_maximal_iff_is_maximal_disjoint (localization M) _ _).mp (by rwa map_bot)).1,
    swap, exact localization.is_localization },
  let M' : submonoid (polynomial R ⧸ P) := M.map φ,
  have hM' : (0 : polynomial R ⧸ P) ∉ M' :=
    λ ⟨z, hz⟩, hM (quotient_map_injective (trans hz.2 φ.map_zero.symm) ▸ hz.1),
  haveI : is_domain (localization M') :=
    is_localization.is_domain_localization (le_non_zero_divisors_of_no_zero_divisors hM'),
  suffices : (⊥ : ideal (localization M')).is_maximal,
  { rw le_antisymm bot_le (comap_bot_le_of_injective _ (is_localization.map_injective_of_injective
      M (localization M) (localization M')
      quotient_map_injective (le_non_zero_divisors_of_no_zero_divisors hM'))),
    refine is_maximal_comap_of_is_integral_of_is_maximal' _ _ ⊥ this,
    apply is_integral_is_localization_polynomial_quotient P _ (submodule.coe_mem m) },
  rw (map_bot.symm : (⊥ : ideal (localization M')) =
                     map (algebra_map (polynomial R ⧸ P) (localization M')) ⊥),
  let bot_maximal := ((bot_quotient_is_maximal_iff _).mpr hP),
  refine map.is_maximal (algebra_map _ _) (localization_map_bijective_of_field hM' _) bot_maximal,
  rwa [← quotient.maximal_ideal_iff_is_field_quotient, ← bot_quotient_is_maximal_iff],
end

/-- Used to bootstrap the more general `quotient_mk_comp_C_is_integral_of_jacobson` -/
private lemma quotient_mk_comp_C_is_integral_of_jacobson' [nontrivial R] (hR : is_jacobson R)
  (hP' : ∀ (x : R), C x ∈ P → x = 0) :
  ((quotient.mk P).comp C : R →+* polynomial R ⧸ P).is_integral :=
begin
  refine (is_integral_quotient_map_iff _).mp _,
  let P' : ideal R := P.comap C,
  obtain ⟨pX, hpX, hp0⟩ :=
    exists_nonzero_mem_of_ne_bot (ne_of_lt (bot_lt_of_maximal P polynomial_not_is_field)).symm hP',
  let M : submonoid (R ⧸ P') := submonoid.powers (pX.map (quotient.mk P')).leading_coeff,
  let φ : R ⧸ P' →+* polynomial R ⧸ P := quotient_map P C le_rfl,
  haveI hp'_prime : P'.is_prime := comap_is_prime C P,
  have hM : (0 : R ⧸ P') ∉ M := λ ⟨n, hn⟩, hp0 $ leading_coeff_eq_zero.mp (pow_eq_zero hn),
  let M' : submonoid (polynomial R ⧸ P) := M.map (quotient_map P C le_rfl),
  refine ((quotient_map P C le_rfl).is_integral_tower_bot_of_is_integral
    (algebra_map _ (localization M')) _ _),
  { refine is_localization.injective (localization M')
      (show M' ≤ _, from le_non_zero_divisors_of_no_zero_divisors (λ hM', hM _)),
    exact (let ⟨z, zM, z0⟩ := hM' in (quotient_map_injective (trans z0 φ.map_zero.symm)) ▸ zM) },
  { rw ← is_localization.map_comp M.le_comap_map,
    refine ring_hom.is_integral_trans (algebra_map (R ⧸ P') (localization M))
      (is_localization.map _ _ M.le_comap_map) _ _,
    { exact (algebra_map (R ⧸ P') (localization M)).is_integral_of_surjective
        (localization_map_bijective_of_field hM
          ((quotient.maximal_ideal_iff_is_field_quotient _).mp
          (is_maximal_comap_C_of_is_maximal P hP'))).2 },
    { -- `convert` here is faster than `exact`, and this proof is near the time limit.
      convert is_integral_is_localization_polynomial_quotient P pX hpX } }
end

/-- If `R` is a Jacobson ring, and `P` is a maximal ideal of `polynomial R`,
  then `R → (polynomial R)/P` is an integral map. -/
lemma quotient_mk_comp_C_is_integral_of_jacobson :
  ((quotient.mk P).comp C : R →+* polynomial R ⧸ P).is_integral :=
begin
  let P' : ideal R := P.comap C,
  haveI : P'.is_prime := comap_is_prime C P,
  let f : polynomial R →+* polynomial (R ⧸ P') := polynomial.map_ring_hom (quotient.mk P'),
  have hf : function.surjective f := map_surjective (quotient.mk P') quotient.mk_surjective,
  have hPJ : P = (P.map f).comap f,
  { rw comap_map_of_surjective _ hf,
    refine le_antisymm (le_sup_of_le_left le_rfl) (sup_le le_rfl _),
    refine λ p hp, polynomial_mem_ideal_of_coeff_mem_ideal P p (λ n, quotient.eq_zero_iff_mem.mp _),
    simpa only [coeff_map, coe_map_ring_hom] using (polynomial.ext_iff.mp hp) n },
  refine ring_hom.is_integral_tower_bot_of_is_integral _ _ (injective_quotient_le_comap_map P) _,
  rw ← quotient_mk_maps_eq,
  refine ring_hom.is_integral_trans _ _
    ((quotient.mk P').is_integral_of_surjective quotient.mk_surjective) _,
  apply quotient_mk_comp_C_is_integral_of_jacobson' _ _ (λ x hx, _),
  any_goals { exact ideal.is_jacobson_quotient },
  { exact or.rec_on (map_eq_top_or_is_maximal_of_surjective f hf hP)
    (λ h, absurd (trans (h ▸ hPJ : P = comap f ⊤) comap_top : P = ⊤) hP.ne_top) id },
  { apply_instance, },
  { obtain ⟨z, rfl⟩ := quotient.mk_surjective x,
    rwa [quotient.eq_zero_iff_mem, mem_comap, hPJ, mem_comap, coe_map_ring_hom, map_C] }
end

lemma is_maximal_comap_C_of_is_jacobson :
  (P.comap (C : R →+* polynomial R)).is_maximal :=
begin
  rw [← @mk_ker _ _ P, ring_hom.ker_eq_comap_bot, comap_comap],
  exact is_maximal_comap_of_is_integral_of_is_maximal' _
    (quotient_mk_comp_C_is_integral_of_jacobson P) ⊥ ((bot_quotient_is_maximal_iff _).mpr hP),
end

omit P hP

lemma comp_C_integral_of_surjective_of_jacobson
  {S : Type*} [field S] (f : (polynomial R) →+* S) (hf : function.surjective f) :
  (f.comp C).is_integral :=
begin
  haveI : (f.ker).is_maximal := f.ker_is_maximal_of_surjective hf,
  let g : polynomial R ⧸ f.ker →+* S := ideal.quotient.lift f.ker f (λ _ h, h),
  have hfg : (g.comp (quotient.mk f.ker)) = f := ring_hom_ext' rfl rfl,
  rw [← hfg, ring_hom.comp_assoc],
  refine ring_hom.is_integral_trans _ g (quotient_mk_comp_C_is_integral_of_jacobson f.ker)
    (g.is_integral_of_surjective _), --(quotient.lift_surjective f.ker f _ hf)),
  rw [← hfg] at hf,
  exact function.surjective.of_comp hf,
end

end

end polynomial

open mv_polynomial ring_hom

namespace mv_polynomial

lemma is_jacobson_mv_polynomial_fin {R : Type*} [comm_ring R] [H : is_jacobson R] :
  ∀ (n : ℕ), is_jacobson (mv_polynomial (fin n) R)
| 0 := ((is_jacobson_iso ((rename_equiv R
  (equiv.equiv_pempty (fin 0))).to_ring_equiv.trans (is_empty_ring_equiv R pempty))).mpr H)
| (n+1) := (is_jacobson_iso (fin_succ_equiv R n).to_ring_equiv).2
  (polynomial.is_jacobson_polynomial_iff_is_jacobson.2 (is_jacobson_mv_polynomial_fin n))

/-- General form of the nullstellensatz for Jacobson rings, since in a Jacobson ring we have
  `Inf {P maximal | P ≥ I} = Inf {P prime | P ≥ I} = I.radical`. Fields are always Jacobson,
  and in that special case this is (most of) the classical Nullstellensatz,
  since `I(V(I))` is the intersection of maximal ideals containing `I`, which is then `I.radical` -/
instance {R : Type*} [comm_ring R] {ι : Type*} [fintype ι] [is_jacobson R] :
  is_jacobson (mv_polynomial ι R) :=
begin
  haveI := classical.dec_eq ι,
  let e := fintype.equiv_fin ι,
  rw is_jacobson_iso (rename_equiv R e).to_ring_equiv,
  exact is_jacobson_mv_polynomial_fin _
end

variables {n : ℕ}

lemma quotient_mk_comp_C_is_integral_of_jacobson
  {R : Type*} [comm_ring R] [is_jacobson R]
  (P : ideal (mv_polynomial (fin n) R)) [P.is_maximal] :
  ((quotient.mk P).comp mv_polynomial.C : R →+* mv_polynomial _ R ⧸ P).is_integral :=
begin
  unfreezingI {induction n with n IH},
  { refine ring_hom.is_integral_of_surjective _ (function.surjective.comp quotient.mk_surjective _),
    exact C_surjective (fin 0) },
  { rw [← fin_succ_equiv_comp_C_eq_C, ← ring_hom.comp_assoc, ← ring_hom.comp_assoc,
      ← quotient_map_comp_mk le_rfl, ring_hom.comp_assoc (polynomial.C),
      ← quotient_map_comp_mk le_rfl, ring_hom.comp_assoc, ring_hom.comp_assoc,
      ← quotient_map_comp_mk le_rfl, ← ring_hom.comp_assoc (quotient.mk _)],
    refine ring_hom.is_integral_trans _ _ _ _,
    { refine ring_hom.is_integral_trans _ _ (is_integral_of_surjective _ quotient.mk_surjective) _,
      refine ring_hom.is_integral_trans _ _ _ _,
      { apply (is_integral_quotient_map_iff _).mpr (IH _),
        apply polynomial.is_maximal_comap_C_of_is_jacobson _,
        { exact mv_polynomial.is_jacobson_mv_polynomial_fin n },
        { apply comap_is_maximal_of_surjective,
          exact (fin_succ_equiv R n).symm.surjective } },
      { refine (is_integral_quotient_map_iff _).mpr _,
        rw ← quotient_map_comp_mk le_rfl,
        refine ring_hom.is_integral_trans _ _ _ ((is_integral_quotient_map_iff _).mpr _),
        { exact ring_hom.is_integral_of_surjective _ quotient.mk_surjective },
        { apply polynomial.quotient_mk_comp_C_is_integral_of_jacobson _,
          { exact mv_polynomial.is_jacobson_mv_polynomial_fin n },
          { exact comap_is_maximal_of_surjective _ (fin_succ_equiv R n).symm.surjective } } } },
    { refine (is_integral_quotient_map_iff _).mpr _,
      refine ring_hom.is_integral_trans _ _ _ (is_integral_of_surjective _ quotient.mk_surjective),
      exact ring_hom.is_integral_of_surjective _ (fin_succ_equiv R n).symm.surjective } }
end

lemma comp_C_integral_of_surjective_of_jacobson
  {R : Type*} [comm_ring R] [is_jacobson R]
  {σ : Type*} [fintype σ] {S : Type*} [field S] (f : mv_polynomial σ R →+* S)
  (hf : function.surjective f) : (f.comp C).is_integral :=
begin
  haveI := classical.dec_eq σ,
  obtain ⟨e⟩ := fintype.trunc_equiv_fin σ,
  let f' : mv_polynomial (fin _) R →+* S :=
    f.comp (rename_equiv R e.symm).to_ring_equiv.to_ring_hom,
  have hf' : function.surjective f' :=
    ((function.surjective.comp hf (rename_equiv R e.symm).surjective)),
  have : (f'.comp C).is_integral,
  { haveI : (f'.ker).is_maximal := f'.ker_is_maximal_of_surjective hf',
    let g : mv_polynomial _ R ⧸ f'.ker →+* S := ideal.quotient.lift f'.ker f' (λ _ h, h),
    have hfg : (g.comp (quotient.mk f'.ker)) = f' := ring_hom_ext (λ r, rfl) (λ i, rfl),
    rw [← hfg, ring_hom.comp_assoc],
    refine ring_hom.is_integral_trans _ g (quotient_mk_comp_C_is_integral_of_jacobson f'.ker)
      (g.is_integral_of_surjective _),
    rw ← hfg at hf',
    exact function.surjective.of_comp hf' },
  rw ring_hom.comp_assoc at this,
  convert this,
  refine ring_hom.ext (λ x, _),
  exact ((rename_equiv R e.symm).commutes' x).symm,
end

end mv_polynomial

end ideal


import tactic

namespace tactic
setup_tactic_parser

meta def nettoyage : tactic unit :=
do try `[dsimp only at * { eta := false, beta := true }],
   try `[simp only [exists_prop] at *]

def force_type (p : Sort*) (x : p) := p

meta def verifie_nom (n : name) :=
success_if_fail (do hyp ← get_local n, skip) <|>
fail ("Le nom " ++ n.to_string ++ " est déjà utilisé.")

@[derive has_reflect]
inductive intro_rel
| lt | gt | le | ge | mem

@[derive has_reflect]
meta inductive introduced
| typed (n : name) (e : pexpr) : introduced
| bare (n : name) : introduced
| related (n : name) (rel : intro_rel) (e : pexpr) : introduced

-- Les deux fonctions suivantes sont en chantier, le but était de permettre d'utiliser introduced
-- aussi dans on obtient

meta def introduced.related_hyp (n : name) (rel : intro_rel) (pe : pexpr) : pexpr :=
match rel with
| intro_rel.lt  := ```(n < %%pe)
| intro_rel.gt  := ```(n > %%pe)
| intro_rel.le  := ```(n ≤ %%pe)
| intro_rel.ge  := ```(n ≥ %%pe)
| intro_rel.mem := ```(n ∈ %%pe)
end

meta def introduced.related_hyp_name (n : name) (rel : intro_rel) (pe : pexpr) : name :=
if pe = ``(0) then
   match rel with
   | intro_rel.lt  := n.to_string ++ "_neg"
   | intro_rel.gt  := n.to_string ++ "_pos"
   | intro_rel.le  := n.to_string ++ "_neg"
   | intro_rel.ge  := n.to_string ++ "_pos"
   | intro_rel.mem := "h_" ++ n.to_string -- ne devrait pas arriver
   end
else
   match rel with
   | intro_rel.lt  := n.to_string ++ "_lt"
   | intro_rel.gt  := n.to_string ++ "_gt"
   | intro_rel.le  := n.to_string ++ "_le"
   | intro_rel.ge  := n.to_string ++ "_ge"
   | intro_rel.mem := n.to_string ++ "_mem"
   end

meta def parse_intro_rel : lean.parser intro_rel :=
intro_rel.lt <$ tk "<" <|>
intro_rel.gt <$ tk ">" <|>
intro_rel.le <$ tk "≤" <|>
intro_rel.le <$ tk "<=" <|>
intro_rel.ge <$ tk "≥" <|>
intro_rel.ge <$ tk ">=" <|>
intro_rel.mem <$ tk "∈"

meta def intro_parser : lean.parser introduced :=
do n ← ident,
   (introduced.typed n <$> (tk ":" *> texpr)) <|>
   (introduced.related n <$> parse_intro_rel <*> texpr) <|>
   pure (introduced.bare n)

meta def bracketed_intro_parser : lean.parser introduced :=
with_desc "..." $
(brackets "(" ")" intro_parser) <|> intro_parser

@[derive has_to_format]
meta def maybe_typed_ident := name × option pexpr

meta def maybe_typed_ident_parser : lean.parser maybe_typed_ident :=
do { n ← (tk "(" *> ident), pe ← (tk ":" *> texpr <* tk ")"), return (n, some pe) } <|>
do { n ← ident,
     do { pe ← (tk ":" *> texpr), pure (n, some pe) } <|> pure (n, none) }

meta def rcases_patt_of_maybe_typed_ident : maybe_typed_ident → rcases_patt
| (n, some pe) := rcases_patt.typed (rcases_patt.one n) pe
| (n, none)    := rcases_patt.one n

meta def rcases_patt_list_of_introduced_list : list introduced → list rcases_patt
| (introduced.typed n pe :: tail) :=
    (rcases_patt.typed (rcases_patt.one n) pe) :: rcases_patt_list_of_introduced_list tail
| (introduced.related n rel pe :: tail) := []
| (introduced.bare n  :: tail) :=
    (rcases_patt.one n) :: rcases_patt_list_of_introduced_list tail
|_ := []

meta def mk_mapp_pexpr_aux : expr → expr → list pexpr → tactic expr
| fn (expr.pi n bi d b) (a::as) :=
do a ← to_expr a,
   infer_type a >>= unify d,
   fn ← head_beta (fn a),
   t ← whnf (b.instantiate_var a),
   mk_mapp_pexpr_aux fn t as
| fn _ [] := pure fn
| fn _ _ := fail "Il y a trop d'arguments"

/-- Applique une expression à une liste de pré-expressions. -/
meta def mk_mapp_pexpr (fn : expr) (args : list pexpr) : tactic expr :=
do t ← infer_type fn >>= whnf,
   mk_mapp_pexpr_aux fn t args

/-- Applique une pré-expression à une liste de pré-expressions. -/
meta def pexpr_mk_app : pexpr → list pexpr → pexpr
| e []      := e
| e (x::xs) := pexpr_mk_app (e x) xs

/-- Parse une liste d'arguments, peut-être vide. -/
meta def applique_a_parser : lean.parser (list pexpr) :=
(tk "appliqué" *> tk "à" *> pexpr_list_or_texpr) <|> pure []

meta def apply_arrow_to_hyp (e : pexpr) (hyp : expr) : tactic unit :=
do {
  t ← infer_type hyp,
  e_expr ← to_expr e,
  e_type ← infer_type e_expr,
  e_is_prop ← is_prop e_type,
  if e_is_prop then do
    prf ← interactive.mk_mapp' e_expr [hyp],
    clear hyp,
    hyp ← note hyp.local_pp_name none prf,
    nettoyage
  else do
    prf ← match t with
    | `(%%l = %%r) := do
          ltp ← infer_type l,
          mv ← mk_mvar,
          to_expr ``(congr_arg (%%e : %%ltp → %%mv) %%hyp)
    | _ := fail ("failed to apply " ++ to_string e ++ " at " ++ to_string hyp.local_pp_name)
    end,
    clear hyp,
    hyp ← note hyp.local_pp_name none prf,
    nettoyage
}

@[interactive]
meta def apply_arrow (q : parse texpr) (locs : parse location)
  : tactic unit :=
match locs with
| (loc.ns l) := l.mmap' $ option.mmap $ λ h, get_local h >>= apply_arrow_to_hyp q
| wildcard   := local_context >>= list.mmap' (apply_arrow_to_hyp q)
end

example (P Q R : Prop) (h : P → Q) (h' : P) : Q :=
begin
  apply_arrow h at h',
  exact h',
end

example (f : ℕ → ℕ) (a b : ℕ) (h : a = b) : f a = f b :=
begin
  apply_arrow f at h,
  exact h
end
/-- Si `e` est une conjonction, on la sépare et on renvoit la liste des deux membres,
    sinon on renvoit la liste [e] -/
meta def split_and (e : expr) : tactic (list expr) :=
do e_type ← infer_type e >>= whnf,
   match e_type with
   | `(%%P ∧ %%Q) := do l ← tactic.cases_core e,
                        pure (l.map (λ x : name × list expr × list (name × expr), x.2.1)).join
   | _ := pure [e]
   end

/- Sépare toutes les conjonctions dans la liste d'expressions -/
meta def split_ands (hyps : list expr) : tactic (list pexpr) :=
do l ← hyps.mmap (λ e : expr, if e.is_local_constant then split_and e else pure [e]),
   pure (l.join.map to_pexpr)

meta def conclure (pe : pexpr) (args : list pexpr) : tactic unit :=
focus1 (do
  let pprf := pexpr_mk_app pe args,
  tgt ← target,
  (i_to_expr_strict ``(%%pprf : %%tgt) >>= exact) <|>
  linarith ff tt [pprf] <|>
  do { proof ← to_expr pprf,
       split_ands [proof] >>= linarith ff tt <|>
       apply proof >> done } <|>
  fail "Cela ne conclut pas")
end tactic


/-
Copyright (c) 2021 Jakob Scholbach. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jakob Scholbach, Joël Riou
-/
import category_theory.comm_sq

/-!
# Lifting properties

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines the lifting property of two morphisms in a category and
shows basic properties of this notion.

## Main results
- `has_lifting_property`: the definition of the lifting property

## Tags
lifting property

@TODO :
1) define llp/rlp with respect to a `morphism_property`
2) retracts, direct/inverse images, (co)products, adjunctions

-/

universe v

namespace category_theory

open category

variables {C : Type*} [category C] {A B B' X Y Y' : C}
  (i : A ⟶ B) (i' : B ⟶ B') (p : X ⟶ Y) (p' : Y ⟶ Y')

/-- `has_lifting_property i p` means that `i` has the left lifting
property with respect to `p`, or equivalently that `p` has
the right lifting property with respect to `i`. -/
class has_lifting_property : Prop :=
(sq_has_lift : ∀ {f : A ⟶ X} {g : B ⟶ Y} (sq : comm_sq f i p g), sq.has_lift)

@[priority 100]
instance sq_has_lift_of_has_lifting_property {f : A ⟶ X} {g : B ⟶ Y} (sq : comm_sq f i p g)
  [hip : has_lifting_property i p] : sq.has_lift := by apply hip.sq_has_lift

namespace has_lifting_property

variables {i p}

lemma op (h : has_lifting_property i p) : has_lifting_property p.op i.op :=
⟨λ f g sq, begin
  simp only [comm_sq.has_lift.iff_unop, quiver.hom.unop_op],
  apply_instance,
end⟩

lemma unop {A B X Y : Cᵒᵖ} {i : A ⟶ B} {p : X ⟶ Y}
  (h : has_lifting_property i p) : has_lifting_property p.unop i.unop :=
⟨λ f g sq, begin
  rw comm_sq.has_lift.iff_op,
  simp only [quiver.hom.op_unop],
  apply_instance,
end⟩

lemma iff_op : has_lifting_property i p ↔ has_lifting_property p.op i.op := ⟨op, unop⟩

lemma iff_unop {A B X Y : Cᵒᵖ} (i : A ⟶ B) (p : X ⟶ Y) :
  has_lifting_property i p ↔ has_lifting_property p.unop i.unop := ⟨unop, op⟩

variables (i p)

@[priority 100]
instance of_left_iso [is_iso i] : has_lifting_property i p :=
⟨λ f g sq, comm_sq.has_lift.mk'
  { l := inv i ≫ f,
    fac_left' := by simp only [is_iso.hom_inv_id_assoc],
    fac_right' := by simp only [sq.w, assoc, is_iso.inv_hom_id_assoc], }⟩

@[priority 100]
instance of_right_iso [is_iso p] : has_lifting_property i p :=
⟨λ f g sq, comm_sq.has_lift.mk'
  { l := g ≫ inv p,
    fac_left' := by simp only [← sq.w_assoc, is_iso.hom_inv_id, comp_id],
    fac_right' := by simp only [assoc, is_iso.inv_hom_id, comp_id], }⟩

instance of_comp_left [has_lifting_property i p] [has_lifting_property i' p] :
  has_lifting_property (i ≫ i') p :=
⟨λ f g sq, begin
  have fac := sq.w,
  rw assoc at fac,
  exact comm_sq.has_lift.mk'
    { l := (comm_sq.mk (comm_sq.mk fac).fac_right).lift,
      fac_left' := by simp only [assoc, comm_sq.fac_left],
      fac_right' := by simp only [comm_sq.fac_right], },
end⟩

instance of_comp_right [has_lifting_property i p] [has_lifting_property i p'] :
  has_lifting_property i (p ≫ p') :=
⟨λ f g sq, begin
  have fac := sq.w,
  rw ← assoc at fac,
  let sq₂ := (comm_sq.mk ((comm_sq.mk fac).fac_left.symm)).lift,
  exact comm_sq.has_lift.mk'
    { l := (comm_sq.mk ((comm_sq.mk fac).fac_left.symm)).lift,
      fac_left' := by simp only [comm_sq.fac_left],
      fac_right' := by simp only [comm_sq.fac_right_assoc, comm_sq.fac_right], },
end⟩

lemma of_arrow_iso_left {A B A' B' X Y : C} {i : A ⟶ B} {i' : A' ⟶ B'}
  (e : arrow.mk i ≅ arrow.mk i') (p : X ⟶ Y)
  [hip : has_lifting_property i p] : has_lifting_property i' p :=
by { rw arrow.iso_w' e, apply_instance, }

lemma of_arrow_iso_right {A B X Y X' Y' : C} (i : A ⟶ B) {p : X ⟶ Y} {p' : X' ⟶ Y'}
  (e : arrow.mk p ≅ arrow.mk p')
  [hip : has_lifting_property i p] : has_lifting_property i p' :=
by { rw arrow.iso_w' e, apply_instance, }

lemma iff_of_arrow_iso_left {A B A' B' X Y : C} {i : A ⟶ B} {i' : A' ⟶ B'}
  (e : arrow.mk i ≅ arrow.mk i') (p : X ⟶ Y) :
  has_lifting_property i p ↔ has_lifting_property i' p :=
by { split; introI, exacts [of_arrow_iso_left e p, of_arrow_iso_left e.symm p], }

lemma iff_of_arrow_iso_right {A B X Y X' Y' : C} (i : A ⟶ B) {p : X ⟶ Y} {p' : X' ⟶ Y'}
  (e : arrow.mk p ≅ arrow.mk p') :
  has_lifting_property i p ↔ has_lifting_property i p' :=
by { split; introI, exacts [of_arrow_iso_right i e, of_arrow_iso_right i e.symm], }

end has_lifting_property

end category_theory


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.comma
import Mathlib.category_theory.groupoid
import Mathlib.category_theory.punit
import Mathlib.PostPort

universes w v u

namespace Mathlib

/-!
# The category of elements

This file defines the category of elements, also known as (a special case of) the Grothendieck construction.

Given a functor `F : C ⥤ Type`, an object of `F.elements` is a pair `(X : C, x : F.obj X)`.
A morphism `(X, x) ⟶ (Y, y)` is a morphism `f : X ⟶ Y` in `C`, so `F.map f` takes `x` to `y`.

## Implementation notes
This construction is equivalent to a special case of a comma construction, so this is mostly just
a more convenient API. We prove the equivalence in `category_theory.category_of_elements.comma_equivalence`.

## References
* [Emily Riehl, *Category Theory in Context*, Section 2.4][riehl2017]
* <https://en.wikipedia.org/wiki/Category_of_elements>
* <https://ncatlab.org/nlab/show/category+of+elements>

## Tags
category of elements, Grothendieck construction, comma category
-/

namespace category_theory

/--
The type of objects for the category of elements of a functor `F : C ⥤ Type`
is a pair `(X : C, x : F.obj X)`.
-/
def functor.elements {C : Type u} [category C] (F : C ⥤ Type w) :=
  sigma fun (c : C) => functor.obj F c

/-- The category structure on `F.elements`, for `F : C ⥤ Type`.
    A morphism `(X, x) ⟶ (Y, y)` is a morphism `f : X ⟶ Y` in `C`, so `F.map f` takes `x` to `y`.
 -/
protected instance category_of_elements {C : Type u} [category C] (F : C ⥤ Type w) : category (functor.elements F) :=
  category.mk

namespace category_of_elements

theorem ext {C : Type u} [category C] (F : C ⥤ Type w) {x : functor.elements F} {y : functor.elements F} (f : x ⟶ y) (g : x ⟶ y) (w : subtype.val f = subtype.val g) : f = g :=
  subtype.ext_val w

@[simp] theorem comp_val {C : Type u} [category C] {F : C ⥤ Type w} {p : functor.elements F} {q : functor.elements F} {r : functor.elements F} {f : p ⟶ q} {g : q ⟶ r} : subtype.val (f ≫ g) = subtype.val f ≫ subtype.val g :=
  rfl

@[simp] theorem id_val {C : Type u} [category C] {F : C ⥤ Type w} {p : functor.elements F} : subtype.val 𝟙 = 𝟙 :=
  rfl

end category_of_elements

protected instance groupoid_of_elements {G : Type u} [groupoid G] (F : G ⥤ Type w) : groupoid (functor.elements F) :=
  groupoid.mk fun (p q : functor.elements F) (f : p ⟶ q) => { val := inv (subtype.val f), property := sorry }

namespace category_of_elements

/-- The functor out of the category of elements which forgets the element. -/
@[simp] theorem π_map {C : Type u} [category C] (F : C ⥤ Type w) (X : functor.elements F) (Y : functor.elements F) (f : X ⟶ Y) : functor.map (π F) f = subtype.val f :=
  Eq.refl (functor.map (π F) f)

/--
A natural transformation between functors induces a functor between the categories of elements.
-/
@[simp] theorem map_obj_fst {C : Type u} [category C] {F₁ : C ⥤ Type w} {F₂ : C ⥤ Type w} (α : F₁ ⟶ F₂) (t : functor.elements F₁) : sigma.fst (functor.obj (map α) t) = sigma.fst t :=
  Eq.refl (sigma.fst (functor.obj (map α) t))

@[simp] theorem map_π {C : Type u} [category C] {F₁ : C ⥤ Type w} {F₂ : C ⥤ Type w} (α : F₁ ⟶ F₂) : map α ⋙ π F₂ = π F₁ :=
  rfl

/-- The forward direction of the equivalence `F.elements ≅ (*, F)`. -/
def to_comma {C : Type u} [category C] (F : C ⥤ Type w) : functor.elements F ⥤ comma (functor.from_punit PUnit) F :=
  functor.mk
    (fun (X : functor.elements F) => comma.mk fun (_x : functor.obj (functor.from_punit PUnit) PUnit.unit) => sigma.snd X)
    fun (X Y : functor.elements F) (f : X ⟶ Y) => comma_morphism.mk

@[simp] theorem to_comma_obj {C : Type u} [category C] (F : C ⥤ Type w) (X : functor.elements F) : functor.obj (to_comma F) X = comma.mk fun (_x : functor.obj (functor.from_punit PUnit) PUnit.unit) => sigma.snd X :=
  rfl

@[simp] theorem to_comma_map {C : Type u} [category C] (F : C ⥤ Type w) {X : functor.elements F} {Y : functor.elements F} (f : X ⟶ Y) : functor.map (to_comma F) f = comma_morphism.mk :=
  rfl

/-- The reverse direction of the equivalence `F.elements ≅ (*, F)`. -/
def from_comma {C : Type u} [category C] (F : C ⥤ Type w) : comma (functor.from_punit PUnit) F ⥤ functor.elements F :=
  functor.mk (fun (X : comma (functor.from_punit PUnit) F) => sigma.mk (comma.right X) (comma.hom X PUnit.unit))
    fun (X Y : comma (functor.from_punit PUnit) F) (f : X ⟶ Y) => { val := comma_morphism.right f, property := sorry }

@[simp] theorem from_comma_obj {C : Type u} [category C] (F : C ⥤ Type w) (X : comma (functor.from_punit PUnit) F) : functor.obj (from_comma F) X = sigma.mk (comma.right X) (comma.hom X PUnit.unit) :=
  rfl

@[simp] theorem from_comma_map {C : Type u} [category C] (F : C ⥤ Type w) {X : comma (functor.from_punit PUnit) F} {Y : comma (functor.from_punit PUnit) F} (f : X ⟶ Y) : functor.map (from_comma F) f =
  { val := comma_morphism.right f, property := congr_fun (Eq.symm (comma_morphism.w' f)) PUnit.unit } :=
  rfl

/-- The equivalence between the category of elements `F.elements`
    and the comma category `(*, F)`. -/
def comma_equivalence {C : Type u} [category C] (F : C ⥤ Type w) : functor.elements F ≌ comma (functor.from_punit PUnit) F :=
  equivalence.mk (to_comma F) (from_comma F)
    (nat_iso.of_components (fun (X : functor.elements F) => eq_to_iso sorry) sorry)
    (nat_iso.of_components (fun (X : comma (functor.from_punit PUnit) F) => iso.mk comma_morphism.mk comma_morphism.mk)
      sorry)

@[simp] theorem comma_equivalence_functor {C : Type u} [category C] (F : C ⥤ Type w) : equivalence.functor (comma_equivalence F) = to_comma F :=
  rfl

@[simp] theorem comma_equivalence_inverse {C : Type u} [category C] (F : C ⥤ Type w) : equivalence.inverse (comma_equivalence F) = from_comma F :=
  rfl


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau, Johan Commelin, Mario Carneiro, Kevin Buzzard
-/
import group_theory.submonoid.basic
import algebra.big_operators.basic
import deprecated.group

/-!
# Unbundled submonoids (deprecated)

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file is deprecated, and is no longer imported by anything in mathlib other than other
deprecated files, and test files. You should not need to import it.

This file defines unbundled multiplicative and additive submonoids. Instead of using this file,
please use `submonoid G` and `add_submonoid A`, defined in `group_theory.submonoid.basic`.

## Main definitions

`is_add_submonoid (S : set M)` : the predicate that `S` is the underlying subset of an additive
submonoid of `M`. The bundled variant `add_submonoid M` should be used in preference to this.

`is_submonoid (S : set M)` : the predicate that `S` is the underlying subset of a submonoid
of `M`. The bundled variant `submonoid M` should be used in preference to this.

## Tags
submonoid, submonoids, is_submonoid
-/

open_locale big_operators

variables {M : Type*} [monoid M] {s : set M}
variables {A : Type*} [add_monoid A] {t : set A}

/-- `s` is an additive submonoid: a set containing 0 and closed under addition.
Note that this structure is deprecated, and the bundled variant `add_submonoid A` should be
preferred. -/
structure is_add_submonoid (s : set A) : Prop :=
(zero_mem : (0:A) ∈ s)
(add_mem {a b} : a ∈ s → b ∈ s → a + b ∈ s)

/-- `s` is a submonoid: a set containing 1 and closed under multiplication.
Note that this structure is deprecated, and the bundled variant `submonoid M` should be
preferred. -/
@[to_additive]
structure is_submonoid (s : set M) : Prop :=
(one_mem : (1:M) ∈ s)
(mul_mem {a b} : a ∈ s → b ∈ s → a * b ∈ s)

lemma additive.is_add_submonoid
  {s : set M} : ∀ (is : is_submonoid s), @is_add_submonoid (additive M) _ s
| ⟨h₁, h₂⟩ := ⟨h₁, @h₂⟩

theorem additive.is_add_submonoid_iff
  {s : set M} : @is_add_submonoid (additive M) _ s ↔ is_submonoid s :=
⟨λ ⟨h₁, h₂⟩, ⟨h₁, @h₂⟩, additive.is_add_submonoid⟩

lemma multiplicative.is_submonoid
  {s : set A} : ∀ (is : is_add_submonoid s), @is_submonoid (multiplicative A) _ s
| ⟨h₁, h₂⟩ := ⟨h₁, @h₂⟩

theorem multiplicative.is_submonoid_iff
  {s : set A} : @is_submonoid (multiplicative A) _ s ↔ is_add_submonoid s :=
⟨λ ⟨h₁, h₂⟩, ⟨h₁, @h₂⟩, multiplicative.is_submonoid⟩

/-- The intersection of two submonoids of a monoid `M` is a submonoid of `M`. -/
@[to_additive "The intersection of two `add_submonoid`s of an `add_monoid` `M` is
an `add_submonoid` of M."]
lemma is_submonoid.inter {s₁ s₂ : set M} (is₁ : is_submonoid s₁) (is₂ : is_submonoid s₂) :
  is_submonoid (s₁ ∩ s₂) :=
{ one_mem := ⟨is₁.one_mem, is₂.one_mem⟩,
  mul_mem := λ x y hx hy,
    ⟨is₁.mul_mem hx.1 hy.1, is₂.mul_mem hx.2 hy.2⟩ }

/-- The intersection of an indexed set of submonoids of a monoid `M` is a submonoid of `M`. -/
@[to_additive "The intersection of an indexed set of `add_submonoid`s of an `add_monoid` `M` is
an `add_submonoid` of `M`."]
lemma is_submonoid.Inter {ι : Sort*} {s : ι → set M} (h : ∀ y : ι, is_submonoid (s y)) :
  is_submonoid (set.Inter s) :=
{ one_mem := set.mem_Inter.2 $ λ y, (h y).one_mem,
  mul_mem := λ x₁ x₂ h₁ h₂, set.mem_Inter.2 $
    λ y, (h y).mul_mem (set.mem_Inter.1 h₁ y) (set.mem_Inter.1 h₂ y) }

/-- The union of an indexed, directed, nonempty set of submonoids of a monoid `M` is a submonoid
    of `M`. -/
@[to_additive "The union of an indexed, directed, nonempty set
of `add_submonoid`s of an `add_monoid` `M` is an `add_submonoid` of `M`. "]
lemma is_submonoid_Union_of_directed {ι : Type*} [hι : nonempty ι]
  {s : ι → set M} (hs : ∀ i, is_submonoid (s i))
  (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
  is_submonoid (⋃i, s i) :=
{ one_mem := let ⟨i⟩ := hι in set.mem_Union.2 ⟨i, (hs i).one_mem⟩,
  mul_mem := λ a b ha hb,
    let ⟨i, hi⟩ := set.mem_Union.1 ha in
    let ⟨j, hj⟩ := set.mem_Union.1 hb in
    let ⟨k, hk⟩ := directed i j in
    set.mem_Union.2 ⟨k, (hs k).mul_mem (hk.1 hi) (hk.2 hj)⟩ }

section powers

/-- The set of natural number powers `1, x, x², ...` of an element `x` of a monoid. -/
@[to_additive multiples
"The set of natural number multiples `0, x, 2x, ...` of an element `x` of an `add_monoid`."]
def powers (x : M) : set M := {y | ∃ n:ℕ, x^n = y}

/-- 1 is in the set of natural number powers of an element of a monoid. -/
@[to_additive "0 is in the set of natural number multiples of an element of an `add_monoid`."]
lemma powers.one_mem {x : M} : (1 : M) ∈ powers x := ⟨0, pow_zero _⟩

/-- An element of a monoid is in the set of that element's natural number powers. -/
@[to_additive
"An element of an `add_monoid` is in the set of that element's natural number multiples."]
lemma powers.self_mem {x : M} : x ∈ powers x := ⟨1, pow_one _⟩

/-- The set of natural number powers of an element of a monoid is closed under multiplication. -/
@[to_additive
"The set of natural number multiples of an element of an `add_monoid` is closed under addition."]
lemma powers.mul_mem {x y z : M} : (y ∈ powers x) → (z ∈ powers x) → (y * z ∈ powers x) :=
λ ⟨n₁, h₁⟩ ⟨n₂, h₂⟩, ⟨n₁ + n₂, by simp only [pow_add, *]⟩

/-- The set of natural number powers of an element of a monoid `M` is a submonoid of `M`. -/
@[to_additive "The set of natural number multiples of an element of
an `add_monoid` `M` is an `add_submonoid` of `M`."]
lemma powers.is_submonoid (x : M) : is_submonoid (powers x) :=
{ one_mem := powers.one_mem,
  mul_mem := λ y z, powers.mul_mem }

/-- A monoid is a submonoid of itself. -/
@[to_additive "An `add_monoid` is an `add_submonoid` of itself."]
lemma univ.is_submonoid : is_submonoid (@set.univ M) := by split; simp

/-- The preimage of a submonoid under a monoid hom is a submonoid of the domain. -/
@[to_additive "The preimage of an `add_submonoid` under an `add_monoid` hom is
an `add_submonoid` of the domain."]
lemma is_submonoid.preimage {N : Type*} [monoid N] {f : M → N} (hf : is_monoid_hom f)
  {s : set N} (hs : is_submonoid s) : is_submonoid (f ⁻¹' s) :=
{ one_mem := show f 1 ∈ s, by rw is_monoid_hom.map_one hf; exact hs.one_mem,
  mul_mem := λ a b (ha : f a ∈ s) (hb : f b ∈ s),
    show f (a * b) ∈ s, by rw is_monoid_hom.map_mul hf; exact hs.mul_mem ha hb }

/-- The image of a submonoid under a monoid hom is a submonoid of the codomain. -/
@[to_additive "The image of an `add_submonoid` under an `add_monoid`
hom is an `add_submonoid` of the codomain."]
lemma is_submonoid.image {γ : Type*} [monoid γ] {f : M → γ} (hf : is_monoid_hom f)
  {s : set M} (hs : is_submonoid s) : is_submonoid (f '' s) :=
{ one_mem := ⟨1, hs.one_mem, hf.map_one⟩,
  mul_mem := λ a b ⟨x, hx⟩ ⟨y, hy⟩, ⟨x * y, hs.mul_mem hx.1 hy.1,
    by rw [hf.map_mul, hx.2, hy.2]⟩ }

/-- The image of a monoid hom is a submonoid of the codomain. -/
@[to_additive "The image of an `add_monoid` hom is an `add_submonoid`
of the codomain."]
lemma range.is_submonoid {γ : Type*} [monoid γ] {f : M → γ} (hf : is_monoid_hom f) :
  is_submonoid (set.range f) :=
by { rw ← set.image_univ, exact univ.is_submonoid.image hf }

/-- Submonoids are closed under natural powers. -/
@[to_additive is_add_submonoid.smul_mem
"An `add_submonoid` is closed under multiplication by naturals."]
lemma is_submonoid.pow_mem {a : M} (hs : is_submonoid s) (h : a ∈ s) : ∀ {n : ℕ}, a ^ n ∈ s
| 0 := by { rw pow_zero, exact hs.one_mem }
| (n + 1) := by { rw pow_succ, exact hs.mul_mem h is_submonoid.pow_mem }

/-- The set of natural number powers of an element of a submonoid is a subset of the submonoid. -/
@[to_additive is_add_submonoid.multiples_subset "The set of natural number multiples of an element
of an `add_submonoid` is a subset of the `add_submonoid`."]
lemma is_submonoid.power_subset {a : M} (hs : is_submonoid s) (h : a ∈ s) : powers a ⊆ s :=
assume x ⟨n, hx⟩, hx ▸ hs.pow_mem h

end powers

namespace is_submonoid

/-- The product of a list of elements of a submonoid is an element of the submonoid. -/
@[to_additive "The sum of a list of elements of an `add_submonoid` is an element of the
`add_submonoid`."]
lemma list_prod_mem (hs : is_submonoid s) : ∀{l : list M}, (∀x∈l, x ∈ s) → l.prod ∈ s
| []     h := hs.one_mem
| (a::l) h :=
  suffices a * l.prod ∈ s, by simpa,
  have a ∈ s ∧ (∀x∈l, x ∈ s), by simpa using h,
  hs.mul_mem this.1 (list_prod_mem this.2)

/-- The product of a multiset of elements of a submonoid of a `comm_monoid` is an element of
the submonoid. -/
@[to_additive "The sum of a multiset of elements of an `add_submonoid` of an `add_comm_monoid`
is an element of the `add_submonoid`. "]
lemma multiset_prod_mem {M} [comm_monoid M] {s : set M} (hs : is_submonoid s) (m : multiset M) :
  (∀a∈m, a ∈ s) → m.prod ∈ s :=
begin
  refine quotient.induction_on m (assume l hl, _),
  rw [multiset.quot_mk_to_coe, multiset.coe_prod],
  exact list_prod_mem hs hl
end

/-- The product of elements of a submonoid of a `comm_monoid` indexed by a `finset` is an element
of the submonoid. -/
@[to_additive "The sum of elements of an `add_submonoid` of an `add_comm_monoid` indexed by
a `finset` is an element of the `add_submonoid`."]
lemma finset_prod_mem {M A} [comm_monoid M] {s : set M} (hs : is_submonoid s) (f : A → M) :
  ∀(t : finset A), (∀b∈t, f b ∈ s) → ∏ b in t, f b ∈ s
| ⟨m, hm⟩ _ := multiset_prod_mem hs _ (by simpa)

end is_submonoid

namespace add_monoid

/-- The inductively defined membership predicate for the submonoid generated by a subset of a
    monoid. -/
inductive in_closure (s : set A) : A → Prop
| basic {a : A} : a ∈ s → in_closure a
| zero : in_closure 0
| add {a b : A} : in_closure a → in_closure b → in_closure (a + b)

end add_monoid

namespace monoid

/-- The inductively defined membership predicate for the `submonoid` generated by a subset of an
    monoid. -/
@[to_additive]
inductive in_closure (s : set M) : M → Prop
| basic {a : M} : a ∈ s → in_closure a
| one : in_closure 1
| mul {a b : M} : in_closure a → in_closure b → in_closure (a * b)

/-- The inductively defined submonoid generated by a subset of a monoid. -/
@[to_additive "The inductively defined `add_submonoid` genrated by a subset of an `add_monoid`."]
def closure (s : set M) : set M := {a | in_closure s a }

@[to_additive]
lemma closure.is_submonoid (s : set M) : is_submonoid (closure s) :=
{ one_mem := in_closure.one, mul_mem := assume a b, in_closure.mul }

/-- A subset of a monoid is contained in the submonoid it generates. -/
@[to_additive "A subset of an `add_monoid` is contained in the `add_submonoid` it generates."]
theorem subset_closure {s : set M} : s ⊆ closure s :=
assume a, in_closure.basic

/-- The submonoid generated by a set is contained in any submonoid that contains the set. -/
@[to_additive "The `add_submonoid` generated by a set is contained in any `add_submonoid` that
contains the set."]
theorem closure_subset {s t : set M} (ht : is_submonoid t) (h : s ⊆ t) : closure s ⊆ t :=
assume a ha, by induction ha; simp [h _, *, is_submonoid.one_mem, is_submonoid.mul_mem]

/-- Given subsets `t` and `s` of a monoid `M`, if `s ⊆ t`, the submonoid of `M` generated by `s` is
    contained in the submonoid generated by `t`. -/
@[to_additive "Given subsets `t` and `s` of an `add_monoid M`, if `s ⊆ t`, the `add_submonoid`
of `M` generated by `s` is contained in the `add_submonoid` generated by `t`."]
theorem closure_mono {s t : set M} (h : s ⊆ t) : closure s ⊆ closure t :=
closure_subset (closure.is_submonoid t) $ set.subset.trans h subset_closure

/-- The submonoid generated by an element of a monoid equals the set of natural number powers of
    the element. -/
@[to_additive "The `add_submonoid` generated by an element of an `add_monoid` equals the set of
natural number multiples of the element."]
theorem closure_singleton {x : M} : closure ({x} : set M) = powers x :=
set.eq_of_subset_of_subset (closure_subset (powers.is_submonoid x) $ set.singleton_subset_iff.2 $
  powers.self_mem) $ is_submonoid.power_subset (closure.is_submonoid _) $
  set.singleton_subset_iff.1 $ subset_closure

/-- The image under a monoid hom of the submonoid generated by a set equals the submonoid generated
    by the image of the set under the monoid hom. -/
@[to_additive "The image under an `add_monoid` hom of the `add_submonoid` generated by a set equals
the `add_submonoid` generated by the image of the set under the `add_monoid` hom."]
lemma image_closure {A : Type*} [monoid A] {f : M → A} (hf : is_monoid_hom f) (s : set M) :
  f '' closure s = closure (f '' s) :=
le_antisymm
  begin
    rintros _ ⟨x, hx, rfl⟩,
    apply in_closure.rec_on hx; intros,
    { solve_by_elim [subset_closure, set.mem_image_of_mem] },
    { rw [hf.map_one], apply is_submonoid.one_mem (closure.is_submonoid (f '' s))},
    { rw [hf.map_mul], solve_by_elim [(closure.is_submonoid _).mul_mem] }
  end
  (closure_subset (is_submonoid.image hf (closure.is_submonoid _)) $
    set.image_subset _ subset_closure)

/-- Given an element `a` of the submonoid of a monoid `M` generated by a set `s`, there exists
a list of elements of `s` whose product is `a`. -/
@[to_additive "Given an element `a` of the `add_submonoid` of an `add_monoid M` generated by
a set `s`, there exists a list of elements of `s` whose sum is `a`."]
theorem exists_list_of_mem_closure {s : set M} {a : M} (h : a ∈ closure s) :
  (∃l:list M, (∀x∈l, x ∈ s) ∧ l.prod = a) :=
begin
  induction h,
  case in_closure.basic : a ha { existsi ([a]), simp [ha] },
  case in_closure.one { existsi ([]), simp },
  case in_closure.mul : a b _ _ ha hb
  { rcases ha with ⟨la, ha, eqa⟩,
    rcases hb with ⟨lb, hb, eqb⟩,
    existsi (la ++ lb),
    simp [eqa.symm, eqb.symm, or_imp_distrib],
    exact assume a, ⟨ha a, hb a⟩ }
end

/-- Given sets `s, t` of a commutative monoid `M`, `x ∈ M` is in the submonoid of `M` generated by
    `s ∪ t` iff there exists an element of the submonoid generated by `s` and an element of the
    submonoid generated by `t` whose product is `x`. -/
@[to_additive "Given sets `s, t` of a commutative `add_monoid M`, `x ∈ M` is in the `add_submonoid`
of `M` generated by `s ∪ t` iff there exists an element of the `add_submonoid` generated by `s`
and an element of the `add_submonoid` generated by `t` whose sum is `x`."]
theorem mem_closure_union_iff {M : Type*} [comm_monoid M] {s t : set M} {x : M} :
  x ∈ closure (s ∪ t) ↔ ∃ y ∈ closure s, ∃ z ∈ closure t, y * z = x :=
⟨λ hx, let ⟨L, HL1, HL2⟩ := exists_list_of_mem_closure hx in HL2 ▸
  list.rec_on L (λ _, ⟨1, (closure.is_submonoid _).one_mem, 1,
    (closure.is_submonoid _).one_mem, mul_one _⟩)
    (λ hd tl ih HL1, let ⟨y, hy, z, hz, hyzx⟩ := ih (list.forall_mem_of_forall_mem_cons HL1) in
      or.cases_on (HL1 hd $ list.mem_cons_self _ _)
        (λ hs, ⟨hd * y, (closure.is_submonoid _).mul_mem (subset_closure hs) hy, z, hz,
          by rw [mul_assoc, list.prod_cons, ← hyzx]; refl⟩)
        (λ ht, ⟨y, hy, z * hd, (closure.is_submonoid _).mul_mem hz (subset_closure ht),
          by rw [← mul_assoc, list.prod_cons, ← hyzx, mul_comm hd]; refl⟩)) HL1,
λ ⟨y, hy, z, hz, hyzx⟩, hyzx ▸ (closure.is_submonoid _).mul_mem
  (closure_mono (set.subset_union_left _ _) hy)
  (closure_mono (set.subset_union_right _ _) hz)⟩

end monoid

/-- Create a bundled submonoid from a set `s` and `[is_submonoid s]`. -/
@[to_additive "Create a bundled additive submonoid from a set `s` and `[is_add_submonoid s]`."]
def submonoid.of {s : set M} (h : is_submonoid s) : submonoid M := ⟨s, λ _ _, h.2, h.1⟩

@[to_additive]
lemma submonoid.is_submonoid (S : submonoid M) : is_submonoid (S : set M) := ⟨S.3, λ _ _, S.2⟩


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Reid Barton, Sean Leather, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.types
import Mathlib.category_theory.epi_mono
import Mathlib.PostPort

universes w v u l u_1 u_2 v' u_3

namespace Mathlib

/-!
# Concrete categories

A concrete category is a category `C` with a fixed faithful functor
`forget : C ⥤ Type*`.  We define concrete categories using `class
concrete_category`.  In particular, we impose no restrictions on the
carrier type `C`, so `Type` is a concrete category with the identity
forgetful functor.

Each concrete category `C` comes with a canonical faithful functor
`forget C : C ⥤ Type*`.  We say that a concrete category `C` admits a
*forgetful functor* to a concrete category `D`, if it has a functor
`forget₂ C D : C ⥤ D` such that `(forget₂ C D) ⋙ (forget D) = forget C`,
see `class has_forget₂`.  Due to `faithful.div_comp`, it suffices
to verify that `forget₂.obj` and `forget₂.map` agree with the equality
above; then `forget₂` will satisfy the functor laws automatically, see
`has_forget₂.mk'`.

Two classes helping construct concrete categories in the two most
common cases are provided in the files `bundled_hom` and
`unbundled_hom`, see their documentation for details.

## References

See [Ahrens and Lumsdaine, *Displayed Categories*][ahrens2017] for
related work.
-/

namespace category_theory

/--
A concrete category is a category `C` with a fixed faithful functor `forget : C ⥤ Type`.

Note that `concrete_category` potentially depends on three independent universe levels,
* the universe level `w` appearing in `forget : C ⥤ Type w`
* the universe level `v` of the morphisms (i.e. we have a `category.{v} C`)
* the universe level `u` of the objects (i.e `C : Type u`)
They are specified that order, to avoid unnecessary universe annotations.
-/
class concrete_category (C : Type u) [category C] where
  forget : C ⥤ Type w
  forget_faithful : faithful forget

/-- The forgetful functor from a concrete category to `Type u`. -/
def forget (C : Type v) [category C] [concrete_category C] : C ⥤ Type u :=
  concrete_category.forget C

/--
Provide a coercion to `Type u` for a concrete category. This is not marked as an instance
as it could potentially apply to every type, and so is too expensive in typeclass search.

You can use it on particular examples as:
```
instance : has_coe_to_sort X := concrete_category.has_coe_to_sort X
```
-/
def concrete_category.has_coe_to_sort (C : Type v) [category C] [concrete_category C] :
    has_coe_to_sort C :=
  has_coe_to_sort.mk (Type u) (functor.obj (concrete_category.forget C))

@[simp] theorem forget_obj_eq_coe {C : Type v} [category C] [concrete_category C] {X : C} :
    functor.obj (forget C) X = ↥X :=
  rfl

/-- Usually a bundled hom structure already has a coercion to function
that works with different universes. So we don't use this as a global instance. -/
def concrete_category.has_coe_to_fun {C : Type v} [category C] [concrete_category C] {X : C}
    {Y : C} : has_coe_to_fun (X ⟶ Y) :=
  has_coe_to_fun.mk (fun (f : X ⟶ Y) => ↥X → ↥Y) fun (f : X ⟶ Y) => functor.map (forget C) f

/-- In any concrete category, we can test equality of morphisms by pointwise evaluations.-/
theorem concrete_category.hom_ext {C : Type v} [category C] [concrete_category C] {X : C} {Y : C}
    (f : X ⟶ Y) (g : X ⟶ Y) (w : ∀ (x : ↥X), coe_fn f x = coe_fn g x) : f = g :=
  faithful.map_injective (forget C) (funext fun (x : functor.obj (forget C) X) => w x)

@[simp] theorem forget_map_eq_coe {C : Type v} [category C] [concrete_category C] {X : C} {Y : C}
    (f : X ⟶ Y) : functor.map (forget C) f = ⇑f :=
  rfl

@[simp] theorem coe_id {C : Type v} [category C] [concrete_category C] {X : C} (x : ↥X) :
    coe_fn 𝟙 x = x :=
  congr_fun (functor.map_id (forget C) X) x

@[simp] theorem coe_comp {C : Type v} [category C] [concrete_category C] {X : C} {Y : C} {Z : C}
    (f : X ⟶ Y) (g : Y ⟶ Z) (x : ↥X) : coe_fn (f ≫ g) x = coe_fn g (coe_fn f x) :=
  congr_fun (functor.map_comp (forget C) f g) x

@[simp] theorem coe_hom_inv_id {C : Type v} [category C] [concrete_category C] {X : C} {Y : C}
    (f : X ≅ Y) (x : ↥X) : coe_fn (iso.inv f) (coe_fn (iso.hom f) x) = x :=
  congr_fun (iso.hom_inv_id (functor.map_iso (forget C) f)) x

@[simp] theorem coe_inv_hom_id {C : Type v} [category C] [concrete_category C] {X : C} {Y : C}
    (f : X ≅ Y) (y : ↥Y) : coe_fn (iso.hom f) (coe_fn (iso.inv f) y) = y :=
  congr_fun (iso.inv_hom_id (functor.map_iso (forget C) f)) y

/-- In any concrete category, injective morphisms are monomorphisms. -/
theorem concrete_category.mono_of_injective {C : Type v} [category C] [concrete_category C] {X : C}
    {Y : C} (f : X ⟶ Y) (i : function.injective ⇑f) : mono f :=
  faithful_reflects_mono (forget C) (iff.mpr (mono_iff_injective ⇑f) i)

/-- In any concrete category, surjective morphisms are epimorphisms. -/
theorem concrete_category.epi_of_surjective {C : Type v} [category C] [concrete_category C] {X : C}
    {Y : C} (f : X ⟶ Y) (s : function.surjective ⇑f) : epi f :=
  faithful_reflects_epi (forget C) (iff.mpr (epi_iff_surjective ⇑f) s)

protected instance concrete_category.types : concrete_category (Type u) := concrete_category.mk 𝟭

/--
`has_forget₂ C D`, where `C` and `D` are both concrete categories, provides a functor
`forget₂ C D : C ⥤ D` and a proof that `forget₂ ⋙ (forget D) = forget C`.
-/
class has_forget₂ (C : Type v) (D : Type v') [category C] [concrete_category C] [category D]
    [concrete_category D]
    where
  forget₂ : C ⥤ D
  forget_comp :
    autoParam (forget₂ ⋙ forget D = forget C)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

/-- The forgetful functor `C ⥤ D` between concrete categories for which we have an instance
`has_forget₂ C `. -/
def forget₂ (C : Type v) (D : Type v') [category C] [concrete_category C] [category D]
    [concrete_category D] [has_forget₂ C D] : C ⥤ D :=
  has_forget₂.forget₂

protected instance forget_faithful (C : Type v) (D : Type v') [category C] [concrete_category C]
    [category D] [concrete_category D] [has_forget₂ C D] : faithful (forget₂ C D) :=
  eq.faithful_of_comp has_forget₂.forget_comp

protected instance induced_category.concrete_category {C : Type v} {D : Type v'} [category D]
    [concrete_category D] (f : C → D) : concrete_category (induced_category D f) :=
  concrete_category.mk (induced_functor f ⋙ forget D)

protected instance induced_category.has_forget₂ {C : Type v} {D : Type v'} [category D]
    [concrete_category D] (f : C → D) : has_forget₂ (induced_category D f) D :=
  has_forget₂.mk (induced_functor f)

/--
In order to construct a “partially forgetting” functor, we do not need to verify functor laws;
it suffices to ensure that compositions agree with `forget₂ C D ⋙ forget D = forget C`.
-/
def has_forget₂.mk' {C : Type v} {D : Type v'} [category C] [concrete_category C] [category D]
    [concrete_category D] (obj : C → D)
    (h_obj : ∀ (X : C), functor.obj (forget D) (obj X) = functor.obj (forget C) X)
    (map : {X Y : C} → (X ⟶ Y) → (obj X ⟶ obj Y))
    (h_map : ∀ {X Y : C} {f : X ⟶ Y}, functor.map (forget D) (map f) == functor.map (forget C) f) :
    has_forget₂ C D :=
  has_forget₂.mk
    (faithful.div (forget C) (forget D) (fun (X : C) => obj X) h_obj
      (fun (X Y : C) (f : X ⟶ Y) => map f) h_map)

protected instance has_forget_to_Type (C : Type v) [category C] [concrete_category C] :
    has_forget₂ C (Type u) :=
  has_forget₂.mk (forget C)

end Mathlib


import ..quotient
import ..transition.iff_lemmas

open mcrl2

variable {α : Type}
variable [comm_semigroup_with_zero α]

/- Here we prove the congruence rules for the operators. -/
inductive R_alt {x₁ x₂ y₁ y₂ : mcrl2 α} (R₁ R₂ : mcrl2 α → mcrl2 α → Prop) :
mcrl2 α → mcrl2 α → Prop
| R₁ (x y) (h : R₁ x y) : R_alt x y
| R₂ (x y) (h : R₂ x y) : R_alt x y
| basel : R_alt (x₁ + y₁) (x₂ + y₂)
| baser : R_alt (x₂ + y₂) (x₁ + y₁)

theorem bisim.alt (x₁ x₂ y₁ y₂: mcrl2 α) (h₁ : x₁ ≈ x₂) (h₂ : y₁ ≈ y₂):
 x₁ + y₁ ≈ x₂ + y₂ :=
begin
  rcases h₁ with ⟨R₁, R₁x, R₁_bisim, R₁_symm⟩,
  rcases h₂ with ⟨R₂, R₂y, R₂_bisim, R₂_symm⟩,
  apply exists.intro (R_alt R₁ R₂),
  apply and.intro,
  { apply R_alt.basel},
  { apply and.intro,
    { intros x y x' a Rxy hxax',
      cases Rxy,
      { have h : ∃ y', transition y a y' ∧ option.rel R₁ x' y',
        by exact bisim_lift (and.intro R₁_bisim R₁_symm) Rxy_h hxax',
        exact bisim_exists_lift R_alt.R₁ h},
      { have h : ∃ y', transition y a y' ∧ option.rel R₂ x' y',
        by exact bisim_lift (and.intro R₂_bisim R₂_symm) Rxy_h hxax',
        exact bisim_exists_lift R_alt.R₂ h},
      { simp only [transition.alt_iff, or_and_distrib_right, exists_or_distrib],
        cases hxax',
        { have h : ∃y', transition x₂ a y' ∧ option.rel R₁ x' y',
          by exact bisim_lift (and.intro R₁_bisim R₁_symm) R₁x hxax'_h,
          left,
          apply bisim_exists_lift R_alt.R₁ h},
        { have h : ∃y', transition y₂ a y' ∧ option.rel R₂ x' y',
          by exact bisim_lift (and.intro R₂_bisim R₂_symm) R₂y hxax'_h,
          right,
          apply bisim_exists_lift R_alt.R₂ h}},
      { simp only [transition.alt_iff, or_and_distrib_right, exists_or_distrib],
        cases hxax',
        { have R₁x' : R₁ x₂ x₁, by apply R₁_symm R₁x,
          have h : ∃y', transition x₁ a y' ∧ option.rel R₁ x' y',
          by exact bisim_lift (and.intro R₁_bisim R₁_symm) R₁x' hxax'_h,
          left,
          apply bisim_exists_lift R_alt.R₁ h},
        { have R₂y' : R₂ y₂ y₁, by apply R₂_symm R₂y,
          have h : ∃y', transition y₁ a y' ∧ option.rel R₂ x' y',
          by exact bisim_lift (and.intro R₂_bisim R₂_symm) R₂y' hxax'_h,
          right,
          apply bisim_exists_lift R_alt.R₂ h}}},
    { intros x y h,
      cases h,
      { apply R_alt.R₁,
        exact R₁_symm h_h},
      { apply R_alt.R₂,
        exact R₂_symm h_h},
      { exact R_alt.baser},
      { exact R_alt.basel}}}
end

inductive R_seq {x₁ x₂ y₁ y₂ : mcrl2 α} (R₁ R₂ : mcrl2 α → mcrl2 α → Prop) :
mcrl2 α → mcrl2 α → Prop
| R₁ (x y) (h : R₁ x y) : R_seq x y
| R₂ (x y) (h : R₂ x y) : R_seq x y
| basel : R_seq (x₁ ⬝ y₁) (x₂ ⬝ y₂)
| baser : R_seq (x₂ ⬝ y₂) (x₁ ⬝ y₁)
| stepl {x y} (h : R₁ x y) : R_seq (x ⬝ y₁) (y ⬝ y₂)
| stepr {x y} (h : R₁ x y) : R_seq (y ⬝ y₂) (x ⬝ y₁)

lemma bisim_exists_lift_seq {x₁ x₂ y₁ y₂ y a x'} {R₁ R₂  : mcrl2 α → mcrl2 α → Prop}
 (hR₂ : R₂ y₁ y₂):
(∃y', transition y a y' ∧ option.rel R₁ x' y') → (∃y', transition y a y' ∧ option.rel (@R_seq _ _ x₁ x₂ y₁ y₂ R₁ R₂) (seq' x' y₁) (seq' y' y₂)) :=
begin
  intro h,
  cases h with w h_w,
  cases h_w with l r,
  apply exists.intro w,
  apply and.intro,
  assumption,
  cases r,
  { cases r,
    apply option.rel.some,
    apply R_seq.stepl,
    assumption},
  { apply option.rel.some,
    apply R_seq.R₂,
    assumption}
end

lemma bisim_exists_lift_seq_symm {x₁ x₂ y₁ y₂ y a x'} {R₁ R₂  : mcrl2 α → mcrl2 α → Prop}
 (hR₂ : R₂ y₂ y₁) (R₁_symm : symmetric R₁):
(∃y', transition y a y' ∧ option.rel R₁ x' y') → (∃y', transition y a y' ∧ option.rel (@R_seq _ _ x₁ x₂ y₁ y₂ R₁ R₂) (seq' x' y₂) (seq' y' y₁)) :=
begin
  intro h,
  cases h with w h_w,
  cases h_w with l r,
  apply exists.intro w,
  apply and.intro,
  assumption,
  cases r,
  { cases r,
    apply option.rel.some,
    apply R_seq.stepr,
    apply R₁_symm,
    assumption},
  { apply option.rel.some,
    apply R_seq.R₂,
    assumption}
end

theorem bisim.seq {x₁ x₂ y₁ y₂: mcrl2 α} (h₁ : x₁ ≈ x₂) (h₂ : y₁ ≈ y₂) :
 x₁ ⬝ y₁ ≈ x₂ ⬝ y₂ :=
begin
  rcases h₁ with ⟨R₁, R₁x, R₁_bisim, R₁_symm⟩,
  rcases h₂ with ⟨R₂, R₂y, R₂_bisim, R₂_symm⟩,
  apply exists.intro (R_seq R₁ R₂),
  apply and.intro,
  { apply R_seq.basel},
  { apply and.intro,
    { intros x y x' a Rxy xax',
      cases Rxy,
      { have h: ∃y', transition y a y' ∧ option.rel R₁ x' y',
        by exact bisim_lift (and.intro R₁_bisim R₁_symm) Rxy_h xax',
        exact bisim_exists_lift R_seq.R₁ h},
      { have h: ∃y', transition y a y' ∧ option.rel R₂ x' y',
        by exact bisim_lift (and.intro R₂_bisim R₂_symm) Rxy_h xax',
        exact bisim_exists_lift R_seq.R₂ h},
      { cases xax',
        simp only [transition.seq_iff, ←exists_and_distrib_right, and_assoc, exists_comm, exists_eq_left],
        specialize R₁_bisim x₁ x₂ xax'_z a R₁x xax'_h,
        apply bisim_exists_lift_seq,
        repeat {assumption}},
      { cases xax',
        simp only [transition.seq_iff, ←exists_and_distrib_right, and_assoc, exists_comm, exists_eq_left],
        specialize R₁_bisim x₂ x₁ xax'_z a (R₁_symm R₁x) xax'_h,
        apply bisim_exists_lift_seq_symm,
        exact (R₂_symm R₂y),
        repeat {assumption}},
      { cases xax',
        simp only [transition.seq_iff, ←exists_and_distrib_right, and_assoc, exists_comm, exists_eq_left],
        specialize R₁_bisim Rxy_x Rxy_y xax'_z a Rxy_h xax'_h,
        apply bisim_exists_lift_seq,
        repeat {assumption}},
      { cases xax',
        simp only [transition.seq_iff, ←exists_and_distrib_right, and_assoc, exists_comm, exists_eq_left],
        specialize R₁_bisim Rxy_y Rxy_x xax'_z a (R₁_symm Rxy_h) xax'_h,
        apply bisim_exists_lift_seq_symm,
        exact (R₂_symm R₂y),
        repeat {assumption}}},
    { intros x y h,
      cases h,
      { apply R_seq.R₁,
        apply R₁_symm,
        assumption},
      { apply R_seq.R₂,
        apply R₂_symm,
        assumption},
      { exact R_seq.baser},
      { exact R_seq.basel},
      { exact R_seq.stepr h_h},
      { exact R_seq.stepl h_h}}}
end