import bridge_char
import rigid_elements.main
import for_mathlib.valuation_subring.basic

noncomputable theory
open_locale tensor_product
open_locale classical

open module

variables {K F : Type*} [field K] [field F] --[is_prime_field F]

open finite_dimensional

namespace main_theorem_mul_setup

lemma mk_rigid_pair
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  rigid_pair (mul_subgroup.mk' T.restrict) (mul_subgroup.mk' T.nonrig.restrict) :=
begin
  let T' := mul_subgroup.mk' T.restrict,
  let H' := mul_subgroup.mk' T.nonrig.restrict,
  have hle' : T' ≤ H',
  { intros t ht,
    use T'.is_unit_of_mem ht,
    apply T.le_nonrig,
    obtain ⟨u,hu⟩ := ht,
    exact hu },
  apply rigid_pair.mk_of_le T' H' hle',
  { refine ⟨(-1 : Kˣ).is_unit, _⟩,
    change _ ∈ T,
    rw [← T.dual_annihilator_dual_annihilator_comap,
      submodule.mem_dual_annihilator_comap_iff],
    intros φ hφ,
    have := hT.neg_one φ hφ,
    convert this, ext, refl },
  { intros x hx hx',
    have hx'' := hx',
    contrapose! hx',
    use is_unit.mk0 x hx,
    change _ ∈ T.nonrig,
    dsimp [submodule.nonrig],
    rw submodule.mem_sup,
    refine ⟨0, T.zero_mem, (units.mk0 x hx).as, _, _⟩,
    { apply submodule.subset_span,
      refine ⟨units.mk0 x hx,_,rfl⟩,
      dsimp [submodule.nonrig_condition],
      split,
      { contrapose! hx'',
        apply hle', use (is_unit.mk0 x hx), dsimp [submodule.restrict],
        change _ ∈ T, convert hx'', ext, refl },
      { intros y hy,
        rw ← hy at hx',
        have : ((units.mk0 x hx)⁻¹ : K) * y = x⁻¹ + 1,
        { field_simp [hy], },
        rw ← this at hx',
        cases hx' with hx'1 hx'2,
        split,
        { contrapose! hx'1,
          use y.is_unit, change _ ∈ T, convert hx'1, ext, refl },
        { contrapose! hx'2,
          use (units.mk0 x hx)⁻¹.is_unit.mul y.is_unit,
          change _ ∈ T, convert hx'2, ext, refl } } },
    { rw zero_add, congr' 1, ext, refl } },
end

lemma mk_rigid_pair_char_two
  [is_prime_field F]
  (htwo : (2 : F) = 0)
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  rigid_pair (mul_subgroup.mk' T.restrict) (mul_subgroup.mk' T.restrict) :=
begin
  let T' := mul_subgroup.mk' T.restrict,
  have hneg1 : (-1 : K) ∈ T',
  { refine ⟨(-1 : Kˣ).is_unit, _⟩,
    change _ ∈ T,
    rw [← T.dual_annihilator_dual_annihilator_comap,
      submodule.mem_dual_annihilator_comap_iff],
    intros φ hφ,
    have := hT.neg_one φ hφ,
    convert this, ext, refl },
  apply rigid_pair.mk_of_le T' T' (le_refl _) hneg1,
  { intros x hx1 hx2,
    let y : Kˣ := units.mk0 x hx1,
    let z : Kˣ := units.mk0 (1 + x) _,
    have hh := submodule.dependent_of_acl _ hT (-y) z _,
    rw fintype.not_linear_independent_iff at hh,
    obtain ⟨g,h1,i,h2⟩ := hh,
    simp only [fin.sum_univ_succ, submodule.mkq_apply, matrix.cons_val_zero,
      fintype.univ_of_subsingleton, fin.mk_zero,
      matrix.cons_val_succ, finset.sum_singleton, fin.succ_zero_eq_one] at h1,
    let a := g 0,
    let b := g 1,
    change a • _ + b • _ = _ at h1,
    cases eq_zero_or_one_of_is_prime_field_of_two _ htwo a with ha ha;
    cases eq_zero_or_one_of_is_prime_field_of_two _ htwo b with hb hb,
    { fin_cases i; contradiction, },
    { simp only [ha,hb, zero_smul, zero_add, one_smul,
        submodule.quotient.mk_eq_zero] at h1,
      left, rw submodule.dual_annihilator_dual_annihilator_comap at h1,
      use z.is_unit, change _ ∈ T, convert h1, ext, refl },
    { simp only [ha,hb, zero_smul, add_zero, one_smul,
        submodule.quotient.mk_eq_zero] at h1,
      exfalso,
      apply hx2,
      rw submodule.dual_annihilator_dual_annihilator_comap at h1,
      rw (show x = (-1 : K) * (-x), by ring), apply T'.mul_mem hneg1,
      use (-y).is_unit, change _ ∈ T, convert h1, ext, refl },
    { simp only [ha,hb, one_smul, ← submodule.mkq_apply,
        ← linear_map.map_add, ← units.as_mul] at h1,
      simp only [submodule.mkq_apply, submodule.quotient.mk_eq_zero,
        submodule.dual_annihilator_dual_annihilator_comap] at h1,
      right,
      have : (2 : F) • y.as = (0 : mul_base_change K F),
      { rw [htwo, zero_smul], },
      rw [← sub_zero (-y * z).as,← this,(show (2 : F) = 1 + 1, by ring),
        add_smul, one_smul, ← units.as_mul, sub_eq_add_neg,
        ← units.as_inv, ← units.as_mul] at h1,
      rw (show (x⁻¹ + 1) = (-1) * (-(x⁻¹ + 1)), by ring),
      apply T'.mul_mem hneg1,
      have : -(x⁻¹ + 1) = ↑(-y * z * (y * y)⁻¹),
      { push_cast, field_simp,
        dsimp [z], ring },
      rw this,
      use (-y * z * (y * y)⁻¹).is_unit, change _ ∈ T, convert h1, ext, refl },
    { dsimp [y,z], ring, },
    { intro c, rw add_eq_zero_iff_neg_eq at c, rw c at hneg1,
      exact hx2 hneg1 } }
end

end main_theorem_mul_setup

theorem main_theorem_mul_char_ne_two
  [is_prime_field F]
  (htwo : (2 : F) ≠ 0)
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  ∃ (R : valuation_subring K)
    (H : submodule F (mul_base_change K F))
    (hTH : T ≤ H)
    (units : ∀ u : Kˣ, u ∈ R.unit_group → u.as ∈ H)
    (principal_units : ∀ u : Kˣ, u ∈ R.principal_unit_group → u.as ∈ T)
    (fd : finite_dimensional F (↥H ⧸ T.comap H.subtype)),
    finrank F (↥H ⧸ T.comap H.subtype) ≤ 1 :=
begin
  let T' := mul_subgroup.mk' T.restrict,
  let H' := mul_subgroup.mk' T.nonrig.restrict,
  let P : rigid_pair T' H' := main_theorem_mul_setup.mk_rigid_pair T hT,
  obtain ⟨t,ht1,ht2,ht3⟩ := P.exists_preadditive,
  let t' : Kˣ := units.mk0 t ht1,
  let E := T.nonrig ⊔ (submodule.span F ({t'.as} : set (mul_base_change K F))),
  have hE : E = T.nonrig,
  { suffices : (submodule.span F ({t'.as} : set (mul_base_change K F))) ≤ T.nonrig,
    { dsimp [E], exact sup_eq_left.mpr this, },
    rw [submodule.span_le, set.singleton_subset_iff],
    change t'.as ∈ T.nonrig,
    suffices : (2 : F) • t'.as ∈ T.nonrig,
    { convert T.nonrig.smul_mem ((2 : F)⁻¹) this using 1,
      rw [← mul_smul, inv_mul_cancel htwo, one_smul] },
    rw [(show (2 : F) = 1 + 1, by ring), add_smul, one_smul, ← units.as_mul],
    obtain ⟨u,hu⟩ := ht2, convert hu, ext, refl },
  let P' : rigid_pair T' (H'.adjoin_ne_zero t ht1) := _,
  change rigid_pair.preadditive P' at ht3,
  let R := ht3.valuation_subring,
  use [R, T.nonrig, T.le_nonrig],
  refine ⟨_,_,_,_⟩,
  { intros u hu,
    rw ← hE,
    suffices : H'.adjoin_ne_zero t ht1 ≤ mul_subgroup.mk' E.restrict,
    { have hh := ht3.mem_of_mem_units u hu,
      change u ∈ E.restrict,
      suffices : (u : K) ∈ mul_subgroup.mk' E.restrict,
      { obtain ⟨h1,h2⟩ := this,
        convert h2, ext, refl },
      exact this hh, },
    apply mul_subgroup.adjoin_ne_zero_le,
    { intros u hu,
      use H'.is_unit_of_mem hu,
      apply submodule.mem_sup_left,
      obtain ⟨v,hv⟩ := hu,
      exact hv },
    { use is_unit.mk0 t ht1,
      apply submodule.mem_sup_right,
      convert submodule.mem_span_singleton_self _, ext, refl } },
  { intros u hu,
    have := ht3.mem_of_mem_principal_units u hu,
    obtain ⟨v,hv⟩ := this,
    convert hv, ext, refl },
  { apply bridge_finite_dimensional _ hT },
  { apply bridge_codim _ hT },
end

theorem main_theorem_mul_char_two
  [is_prime_field F]
  (htwo : (2 : F) = 0)
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  ∃ (R : valuation_subring K)
    (H : submodule F (mul_base_change K F))
    (hTH : T ≤ H)
    (units : ∀ u : Kˣ, u ∈ R.unit_group → u.as ∈ H)
    (principal_units : ∀ u : Kˣ, u ∈ R.principal_unit_group → u.as ∈ T)
    (fd : finite_dimensional F (↥H ⧸ T.comap H.subtype)),
    finrank F (↥H ⧸ T.comap H.subtype) ≤ 1 :=
begin
  let T' := mul_subgroup.mk' T.restrict,
  let P : rigid_pair T' T' :=
    main_theorem_mul_setup.mk_rigid_pair_char_two htwo T hT,
  obtain ⟨t,ht1,ht2,ht3⟩ := P.exists_preadditive,
  let t' : Kˣ := units.mk0 t ht1,
  let P' : rigid_pair T' (T'.adjoin_ne_zero t ht1) := _,
  change rigid_pair.preadditive P' at ht3,
  let R := ht3.valuation_subring, use R,
  let H := T ⊔ (submodule.span F ({t'.as} : set (mul_base_change K F))),
  have hfd : finite_dimensional F (↥H ⧸ (T.comap H.subtype)),
  { let e := (T.comap H.subtype).mkq.comp (submodule.of_le (le_sup_right : _ ≤ T ⊔ _)),
    have he : function.surjective e,
    { apply submodule.mkq_comp_sup_mod_surjective },
    apply e.finite_dimensional_of_surjective, rwa linear_map.range_eq_top },
  use [H, le_sup_left],
  refine ⟨_,_,_,_⟩,
  { intros u hu,
    have hh := ht3.mem_of_mem_units u hu,
    suffices : T'.adjoin_ne_zero t ht1 ≤ mul_subgroup.mk' H.restrict,
    { replace hh := this hh,
      obtain ⟨v,hv⟩ := hh,
      convert hv, ext, refl },
    apply mul_subgroup.adjoin_ne_zero_le,
    { intros u hu, use T'.is_unit_of_mem hu, change _ ∈ H,
      apply submodule.mem_sup_left, obtain ⟨v,hv⟩ := hu, exact hv },
    { use t'.is_unit,
      apply submodule.mem_sup_right,
      convert submodule.mem_span_singleton_self _, ext, refl } },
  { intros u hu,
    have := ht3.mem_of_mem_principal_units u hu,
    obtain ⟨v,hv⟩ := this,
    convert hv, ext, refl },
  { exact hfd },
  { by_cases htT : t ∈ T',
    { have : H = T,
      { erw [sup_eq_left],
        rw submodule.span_singleton_le_iff_mem, obtain ⟨v,hv⟩ := htT, convert hv, ext, refl },
      rw this at hfd ⊢, resetI, rw finrank_le_one_iff, use 0, rintros ⟨w,hw⟩, use 0,
      symmetry,
      simp, },
    apply submodule.finrank_le_one_of_not_linear_independent T {t'.as} t'.as
      (set.mem_singleton (units.as t')),
    { contrapose! htT,
      use t'.is_unit, change _ ∈ T, convert htT, ext, refl },
    { rintros v (rfl : v = t'.as),
      rw fintype.not_linear_independent_iff, use ![1,-1],
      split, { simp [fin.sum_univ_succ] }, { use 0, norm_num } } },
end

theorem main_theorem_mul
  [is_prime_field F]
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  ∃ (R : valuation_subring K)
    (H : submodule F (mul_base_change K F))
    (hTH : T ≤ H)
    (units : ∀ u : Kˣ, u ∈ R.unit_group → u.as ∈ H)
    (principal_units : ∀ u : Kˣ, u ∈ R.principal_unit_group → u.as ∈ T)
    (fd : finite_dimensional F (↥H ⧸ T.comap H.subtype)),
    finrank F (↥H ⧸ T.comap H.subtype) ≤ 1 :=
begin
  by_cases htwo : (2 : F) = 0,
  apply main_theorem_mul_char_two, assumption',
  apply main_theorem_mul_char_ne_two, assumption'
end

theorem main_theorem_mul_char
  (p ℓ : ℕ)
  [fact (nat.prime p)]
  (HH : p ≠ ℓ)
  [char_p K p]
  [char_p F ℓ]
  (htwo : (2 : F) ≠ 0)
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  ∃ (R : valuation_subring K)
    (H : submodule F (mul_base_change K F))
    (hTH : T ≤ H)
    (units : ∀ u : Kˣ, u ∈ R.unit_group → u.as ∈ H)
    (principal_units : ∀ u : Kˣ, u ∈ R.principal_unit_group → u.as ∈ T)
    (fd : finite_dimensional F (↥H ⧸ T.comap H.subtype)),
    finrank F (↥H ⧸ T.comap H.subtype) ≤ 1 :=
begin
  let T' := mul_subgroup.mk' T.restrict,
  let H' := mul_subgroup.mk' T.nonrig.restrict,
  let P : rigid_pair T' H' := main_theorem_mul_setup.mk_rigid_pair T hT,
  obtain ⟨t,ht1,ht2,ht3⟩ := P.exists_preadditive,
  let t' : Kˣ := units.mk0 t ht1,
  let E := T.nonrig ⊔ (submodule.span F ({t'.as} : set (mul_base_change K F))),
  have hE : E = T.nonrig,
  { suffices : (submodule.span F ({t'.as} : set (mul_base_change K F))) ≤ T.nonrig,
    { dsimp [E], exact sup_eq_left.mpr this, },
    rw [submodule.span_le, set.singleton_subset_iff],
    change t'.as ∈ T.nonrig,
    suffices : (2 : F) • t'.as ∈ T.nonrig,
    { convert T.nonrig.smul_mem ((2 : F)⁻¹) this using 1,
      rw [← mul_smul, inv_mul_cancel htwo, one_smul] },
    rw [(show (2 : F) = 1 + 1, by ring), add_smul, one_smul, ← units.as_mul],
    obtain ⟨u,hu⟩ := ht2, convert hu, ext, refl },
  let P' : rigid_pair T' (H'.adjoin_ne_zero t ht1) := _,
  change rigid_pair.preadditive P' at ht3,
  let R := ht3.valuation_subring,
  use [R, T.nonrig, T.le_nonrig],
  refine ⟨_,_,_,_⟩,
  { intros u hu,
    rw ← hE,
    suffices : H'.adjoin_ne_zero t ht1 ≤ mul_subgroup.mk' E.restrict,
    { have hh := ht3.mem_of_mem_units u hu,
      change u ∈ E.restrict,
      suffices : (u : K) ∈ mul_subgroup.mk' E.restrict,
      { obtain ⟨h1,h2⟩ := this,
        convert h2, ext, refl },
      exact this hh, },
    apply mul_subgroup.adjoin_ne_zero_le,
    { intros u hu,
      use H'.is_unit_of_mem hu,
      apply submodule.mem_sup_left,
      obtain ⟨v,hv⟩ := hu,
      exact hv },
    { use is_unit.mk0 t ht1,
      apply submodule.mem_sup_right,
      convert submodule.mem_span_singleton_self _, ext, refl } },
  { intros u hu,
    have := ht3.mem_of_mem_principal_units u hu,
    obtain ⟨v,hv⟩ := this,
    convert hv, ext, refl },
  { apply bridge_char_finite_dimensional p ℓ HH _ hT },
  { apply bridge_char_codim p ℓ HH _ hT },
end


import FOL.completeness

universes u v

namespace fol
open_locale logic_symbol
variables {L L₁ L₂ L₃ : language.{u}} {T₁ U₁ : Theory L₁} {T₂ U₂ : Theory L₂} {T₃ U₃ : Theory L₃}
open formula language language.language_translation language.language_translation_coe

namespace Theory

section
variables [closed_Theory T₁] [closed_Theory U₁] [language_translation_coe L₁ L₂]
open logic logic.Theory axiomatic_classical_logic' axiomatic_classical_logic

@[simp] lemma le_coe_iff : (↑T₁ : Theory L₂) ≤ ↑U₁ ↔ T₁ ≤ U₁ :=
⟨λ h p b,
  by { have : (↑T₁ : Theory L₂) ⊢ ↑p, by simp[b],
       have : ↑U₁ ⊢ ↑p, from h this,
       simpa using this },
 λ h p b,
begin
  rcases provable.proof_conjunction b with ⟨P, hP, b⟩,
  have : ∀ p, ∃ p₁ : formula L₁, p ∉ P ∨ p = ↑p₁ ∧ p₁ ∈ T₁,
  { intros p, by_cases hp : p ∈ P,
    { rcases language.language_translation_coe.mem_coe_iff.mp (hP p hp) with ⟨p₁, hp₁, rfl⟩,
      refine ⟨p₁, by simp[hp₁]⟩ },
    { simp[hp] } },
  choose coe_inv hcoe_inv using this,
  have : ↑U₁ ⊢ P.conjunction,
    from list_conjunction_provable
      (λ p hp, by { rcases language.language_translation_coe.mem_coe_iff.mp (hP p hp) with ⟨p₁, hp₁, rfl⟩,
        simpa using h (by_axiom hp₁) }),
  exact b.extend ⨀ this
end⟩

instance extend_coe [T₁.extend U₁] : (↑T₁ : Theory L₂).extend ↑U₁ := ⟨le_coe_iff.mpr extend.le⟩

end

variables [language_translation_coe L₁ L₂] {T₁ U₁} {T₂ U₂}

def lle (T₁ : Theory L₁) (T₂ : Theory L₂) : Prop := ∀ ⦃p : formula L₁⦄, T₁ ⊢ p → T₂ ⊢ p

@[simp] lemma lle_refl (T : Theory L) : lle T T := λ p h, by simp[coe_def_p, ltr]; exact h

@[trans] lemma lle_trans [language_translation_coe L₁ L₂] [language_translation_coe L₂ L₃] [language_translation_coe L₁ L₃]
  {T₁ : Theory L₁} {T₂ : Theory L₂} {T₃ : Theory L₃} [commutes L₁ L₂ L₃] :
  lle T₁ T₂ → lle T₂ T₃ → lle T₁ T₃ :=
λ le₁₂ le₂₃ p₁ b₁, by simpa[commutes.coe_coe_p_of_commute p₁] using le₂₃ (le₁₂ b₁)

lemma lle_of_le (h : T₁ ≤ U₁) : lle T₁ U₁ := λ p b, by simp[coe_def_p, ltr]; exact h b

variables {T₁ U₂} (T₂)

lemma lle_of_lle_of_le (h : lle T₁ T₂) (le : T₂ ≤ U₂) : lle T₁ U₂ := λ p b, le (h b)

variables {T₁ T₂} (U₁)

lemma lle_of_le_of_lle (le : T₁ ≤ U₁) (h : lle U₁ T₂) : lle T₁ T₂ := λ p b, h (le b)

variables (T₁)

lemma lle_coe [closed_Theory T₁] : lle T₁ (↑T₁ : Theory L₂) := λ p, by simp

end Theory

class lextend {L₁ : language.{u}} {L₂ : language.{u}} [language_translation_coe L₁ L₂] (T₁ : Theory L₁) (T₂ : Theory L₂) :=
(le : Theory.lle T₁ T₂)

lemma provable.lextend [language_translation_coe L₁ L₂] {T₁ : Theory L₁} {p} (b : T₁ ⊢ p) (T₂ : Theory L₂)
  [lextend T₁ T₂] : T₂ ⊢ p := lextend.le b

namespace Theory
open logic logic.Theory
variables  [language_translation_coe L₁ L₂] (T₁ U₁) (T₂ U₂)

instance lextend_refl : lextend T₁ T₁ := ⟨by simp⟩

instance lextend_of_extend [extend T₁ U₁] : lextend T₁ U₁ := ⟨lle_of_le extend.le⟩

instance lextend_sf [lextend T₁ T₂] : lextend (⤊T₁) (⤊T₂) :=
⟨λ p h, by {
  have : T₁ ⊢ ∀.p, from h.generalize,
  have : T₂ ⊢ ∀.p, from provable.lextend this T₂,
  have : ⤊T₂ ⊢ (∀.p)^1, from provable.sf_sf.mpr this,
  simpa[formula.nested_rew] using this ⊚ #0 }⟩

instance lextend_pow [ex : lextend T₁ T₂] (k : ℕ) : lextend (T₁^k) (T₂^k) :=
by { induction k with k IH ; simp[Theory.sf_itr_succ], { exact ex }, { exactI fol.Theory.lextend_sf _ _ } }

instance lextend_sf_closed [closed_Theory T₁] [lextend T₁ T₂] : lextend T₁ (⤊T₂) :=
by simpa using Theory.lextend_sf T₁ T₂

instance lextend_pow_closed [closed_Theory T₁] [lextend T₁ T₂] (k : ℕ) : lextend T₁ (T₂^k) :=
by simpa using Theory.lextend_pow T₁ T₂ k

instance lextend_coe [closed_Theory T₁] : lextend T₁ (↑T₁ : Theory L₂) := ⟨lle_coe T₁⟩

variables (T₁ U₂ T₂)

def lextend_of_lextend_of_extend [lextend T₁ T₂] [extend T₂ U₂] : lextend T₁ U₂ := ⟨lle_of_lle_of_le T₂ lextend.le extend.le⟩

variables (T₁ T₂ U₁)

def lextend_of_extend_of_lextend [extend T₁ U₁] [lextend U₁ T₂] : lextend T₁ T₂ := ⟨lle_of_le_of_lle U₁ extend.le lextend.le⟩

section
variables {T₁ T₂} [lextend T₁ T₂]

instance lextend_insert₁ (p) : lextend T₁ (T₂+{p}) := lextend_of_lextend_of_extend _ T₂ _

instance lextend_insert₂ (p q) : lextend T₁ (T₂+{p}+{q}) := lextend_of_lextend_of_extend _ T₂ _

instance lextend_insert₃ (p q r) : lextend T₁ (T₂+{p}+{q}+{r}) := lextend_of_lextend_of_extend _ T₂ _

instance lextend_insert₄ (p q r s) : lextend T₁ (T₂+{p}+{q}+{r}+{s}) := lextend_of_lextend_of_extend _ T₂ _

end

section
variables [language_translation_coe L₁ L₂] [language_translation_coe L₂ L₃] [language_translation_coe L₁ L₃]
  [commutes L₁ L₂ L₃] (T₁ T₂ T₃)

def lextend_trans [lextend T₁ T₂] [lextend T₂ T₃] : lextend T₁ T₃ := ⟨lle_trans (show lle T₁ T₂, from lextend.le) lextend.le⟩

end

end Theory

variables {L₁ L₂} (D : L₁.definitions L₂) [language_translation_coe (L₁ + L₂) L₃]
  [language_translation_coe L₁ L₃] [commutes L₁ (L₁ + L₂) L₃] (T : Theory L₃) [lextend D.thy T]

@[simp] lemma language.definitions.fn' {n} (f : L₂.fn n) (v : finitary (term L₃) n) :
  T ⊢ (D.df_fn f : formula L₃).rew (term.app ((coe : (L₁ + L₂).fn n → L₃.fn n) (sum.inr f)) v ⌢ of_fin v) :=
by { have : T ⊢ ∀.[n] (D.df_fn f : formula L₃).rew ı[0 ⇝ term.app ↑(sum.inr f)  (λ i, #i)],
       by simpa using provable.lextend (axiomatic_classical_logic'.by_axiom (language.definitions.mem_fn D f)) T,
     have := provable.nfal_subst'_finitary this v,
     simp[formula.nested_rew] at this,
     refine cast (by { congr, funext x, rcases x; simp }) this }

@[simp] lemma language.definitions.pr' {n} (r : L₂.pr n) (v : finitary (term L₃) n) :
  T ⊢ app ((coe : (L₁ + L₂).pr n → L₃.pr n) (sum.inr r)) v ⟷ (D.df_pr r : formula L₃).rew (of_fin v) :=
by { have : T ⊢ ∀.[n] ❴↑(sum.inr r)❵ (λ i, #i) ⟷ ↑(D.df_pr r),
       by simpa using provable.lextend (axiomatic_classical_logic'.by_axiom (language.definitions.mem_pr D r)) T,
     simpa using provable.nfal_subst'_finitary this v }

lemma coe_inv_equiv' [language.predicate L₂] (p : formula (L₁ + L₂)) :
  T ⊢ p ⟷ ↑(formula.coe_inv D p : formula L₁) :=
by simpa using provable.lextend (coe_inv_equiv D p) T

end fol


/-
Copyright (c) 2021 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import measure_theory.measure.measure_space

/-!
# Almost everywhere measurable functions

A function is almost everywhere measurable if it coincides almost everywhere with a measurable
function. This property, called `ae_measurable f μ`, is defined in the file `measure_space_def`.
We discuss several of its properties that are analogous to properties of measurable functions.
-/

open measure_theory measure_theory.measure filter set function
open_locale measure_theory filter classical ennreal interval

variables {ι α β γ δ R : Type*} {m0 : measurable_space α} [measurable_space β]
   [measurable_space γ] [measurable_space δ] {f g : α → β} {μ ν : measure α}

include m0

section

@[nontriviality, measurability]
lemma subsingleton.ae_measurable [subsingleton α] : ae_measurable f μ :=
subsingleton.measurable.ae_measurable

@[nontriviality, measurability]
lemma ae_measurable_of_subsingleton_codomain [subsingleton β] : ae_measurable f μ :=
(measurable_of_subsingleton_codomain f).ae_measurable

@[simp, measurability] lemma ae_measurable_zero_measure : ae_measurable f (0 : measure α) :=
begin
  nontriviality α, inhabit α,
  exact ⟨λ x, f default, measurable_const, rfl⟩
end

namespace ae_measurable

lemma mono_measure (h : ae_measurable f μ) (h' : ν ≤ μ) : ae_measurable f ν :=
⟨h.mk f, h.measurable_mk, eventually.filter_mono (ae_mono h') h.ae_eq_mk⟩

lemma mono_set {s t} (h : s ⊆ t) (ht : ae_measurable f (μ.restrict t)) :
  ae_measurable f (μ.restrict s) :=
ht.mono_measure (restrict_mono h le_rfl)

protected lemma mono' (h : ae_measurable f μ) (h' : ν ≪ μ) : ae_measurable f ν :=
⟨h.mk f, h.measurable_mk, h' h.ae_eq_mk⟩

lemma ae_mem_imp_eq_mk {s} (h : ae_measurable f (μ.restrict s)) :
  ∀ᵐ x ∂μ, x ∈ s → f x = h.mk f x :=
ae_imp_of_ae_restrict h.ae_eq_mk

lemma ae_inf_principal_eq_mk {s} (h : ae_measurable f (μ.restrict s)) :
  f =ᶠ[μ.ae ⊓ 𝓟 s] h.mk f :=
le_ae_restrict h.ae_eq_mk

@[measurability]
lemma sum_measure [encodable ι] {μ : ι → measure α} (h : ∀ i, ae_measurable f (μ i)) :
  ae_measurable f (sum μ) :=
begin
  nontriviality β, inhabit β,
  set s : ι → set α := λ i, to_measurable (μ i) {x | f x ≠ (h i).mk f x},
  have hsμ : ∀ i, μ i (s i) = 0,
  { intro i, rw measure_to_measurable, exact (h i).ae_eq_mk },
  have hsm : measurable_set (⋂ i, s i),
    from measurable_set.Inter (λ i, measurable_set_to_measurable _ _),
  have hs : ∀ i x, x ∉ s i → f x = (h i).mk f x,
  { intros i x hx, contrapose! hx, exact subset_to_measurable _ _ hx },
  set g : α → β := (⋂ i, s i).piecewise (const α default) f,
  refine ⟨g, measurable_of_restrict_of_restrict_compl hsm _ _, ae_sum_iff.mpr $ λ i, _⟩,
  { rw [restrict_piecewise], simp only [set.restrict, const], exact measurable_const },
  { rw [restrict_piecewise_compl, compl_Inter],
    intros t ht,
    refine ⟨⋃ i, ((h i).mk f ⁻¹' t) ∩ (s i)ᶜ, measurable_set.Union $
      λ i, (measurable_mk _ ht).inter (measurable_set_to_measurable _ _).compl, _⟩,
    ext ⟨x, hx⟩,
    simp only [mem_preimage, mem_Union, subtype.coe_mk, set.restrict, mem_inter_eq,
      mem_compl_iff] at hx ⊢,
    split,
    { rintro ⟨i, hxt, hxs⟩, rwa hs _ _ hxs },
    { rcases hx with ⟨i, hi⟩, rw hs _ _ hi, exact λ h, ⟨i, h, hi⟩ } },
  { refine measure_mono_null (λ x (hx : f x ≠ g x), _) (hsμ i),
    contrapose! hx, refine (piecewise_eq_of_not_mem _ _ _ _).symm,
    exact λ h, hx (mem_Inter.1 h i) }
end

@[simp] lemma _root_.ae_measurable_sum_measure_iff [encodable ι] {μ : ι → measure α} :
  ae_measurable f (sum μ) ↔ ∀ i, ae_measurable f (μ i) :=
⟨λ h i, h.mono_measure (le_sum _ _), sum_measure⟩

@[simp] lemma _root_.ae_measurable_add_measure_iff :
  ae_measurable f (μ + ν) ↔ ae_measurable f μ ∧ ae_measurable f ν :=
by { rw [← sum_cond, ae_measurable_sum_measure_iff, bool.forall_bool, and.comm], refl }

@[measurability]
lemma add_measure {f : α → β} (hμ : ae_measurable f μ) (hν : ae_measurable f ν) :
  ae_measurable f (μ + ν) :=
ae_measurable_add_measure_iff.2 ⟨hμ, hν⟩

@[measurability]
protected lemma Union [encodable ι] {s : ι → set α} (h : ∀ i, ae_measurable f (μ.restrict (s i))) :
  ae_measurable f (μ.restrict (⋃ i, s i)) :=
(sum_measure h).mono_measure $ restrict_Union_le

@[simp] lemma _root_.ae_measurable_Union_iff [encodable ι] {s : ι → set α} :
  ae_measurable f (μ.restrict (⋃ i, s i)) ↔ ∀ i, ae_measurable f (μ.restrict (s i)) :=
⟨λ h i, h.mono_measure $ restrict_mono (subset_Union _ _) le_rfl, ae_measurable.Union⟩

@[simp] lemma _root_.ae_measurable_union_iff {s t : set α} :
  ae_measurable f (μ.restrict (s ∪ t)) ↔
    ae_measurable f (μ.restrict s) ∧ ae_measurable f (μ.restrict t) :=
by simp only [union_eq_Union, ae_measurable_Union_iff, bool.forall_bool, cond, and.comm]

@[measurability]
lemma smul_measure [monoid R] [distrib_mul_action R ℝ≥0∞] [is_scalar_tower R ℝ≥0∞ ℝ≥0∞]
  (h : ae_measurable f μ) (c : R) :
  ae_measurable f (c • μ) :=
⟨h.mk f, h.measurable_mk, ae_smul_measure h.ae_eq_mk c⟩

lemma comp_ae_measurable {f : α → δ} {g : δ → β}
  (hg : ae_measurable g (μ.map f)) (hf : ae_measurable f μ) : ae_measurable (g ∘ f) μ :=
⟨hg.mk g ∘ hf.mk f, hg.measurable_mk.comp hf.measurable_mk,
  (ae_eq_comp hf hg.ae_eq_mk).trans ((hf.ae_eq_mk).fun_comp (mk g hg))⟩

lemma comp_measurable {f : α → δ} {g : δ → β}
  (hg : ae_measurable g (μ.map f)) (hf : measurable f) : ae_measurable (g ∘ f) μ :=
hg.comp_ae_measurable hf.ae_measurable

lemma comp_measurable' {ν : measure δ} {f : α → δ} {g : δ → β} (hg : ae_measurable g ν)
  (hf : measurable f) (h : μ.map f ≪ ν) : ae_measurable (g ∘ f) μ :=
(hg.mono' h).comp_measurable hf

lemma map_map_of_ae_measurable {g : β → γ} {f : α → β}
  (hg : ae_measurable g (measure.map f μ)) (hf : ae_measurable f μ) :
  (μ.map f).map g = μ.map (g ∘ f) :=
begin
  ext1 s hs,
  let g' := hg.mk g,
  have A : map g (map f μ) = map g' (map f μ),
  { apply measure_theory.measure.map_congr,
    exact hg.ae_eq_mk },
  have B : map (g ∘ f) μ = map (g' ∘ f) μ,
  { apply measure_theory.measure.map_congr,
    exact ae_of_ae_map hf hg.ae_eq_mk },
  simp only [A, B, hs, hg.measurable_mk.ae_measurable.comp_ae_measurable hf, hg.measurable_mk,
    hg.measurable_mk hs, hf, map_apply, map_apply_of_ae_measurable],
  refl,
end

@[measurability]
lemma prod_mk {f : α → β} {g : α → γ} (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  ae_measurable (λ x, (f x, g x)) μ :=
⟨λ a, (hf.mk f a, hg.mk g a), hf.measurable_mk.prod_mk hg.measurable_mk,
  eventually_eq.prod_mk hf.ae_eq_mk hg.ae_eq_mk⟩

lemma exists_ae_eq_range_subset (H : ae_measurable f μ) {t : set β} (ht : ∀ᵐ x ∂μ, f x ∈ t)
  (h₀ : t.nonempty) :
  ∃ g, measurable g ∧ range g ⊆ t ∧ f =ᵐ[μ] g :=
begin
  let s : set α := to_measurable μ {x | f x = H.mk f x ∧ f x ∈ t}ᶜ,
  let g : α → β := piecewise s (λ x, h₀.some) (H.mk f),
  refine ⟨g, _, _, _⟩,
  { exact measurable.piecewise (measurable_set_to_measurable _ _)
      measurable_const H.measurable_mk },
  { rintros _ ⟨x, rfl⟩,
    by_cases hx : x ∈ s,
    { simpa [g, hx] using h₀.some_mem },
    { simp only [g, hx, piecewise_eq_of_not_mem, not_false_iff],
      contrapose! hx,
      apply subset_to_measurable,
      simp only [hx, mem_compl_eq, mem_set_of_eq, not_and, not_false_iff, implies_true_iff]
        {contextual := tt} } },
  { have A : μ (to_measurable μ {x | f x = H.mk f x ∧ f x ∈ t}ᶜ) = 0,
    { rw [measure_to_measurable, ← compl_mem_ae_iff, compl_compl],
      exact H.ae_eq_mk.and ht },
    filter_upwards [compl_mem_ae_iff.2 A] with x hx,
    rw mem_compl_iff at hx,
    simp only [g, hx, piecewise_eq_of_not_mem, not_false_iff],
    contrapose! hx,
    apply subset_to_measurable,
    simp only [hx, mem_compl_eq, mem_set_of_eq, false_and, not_false_iff] }
end

lemma subtype_mk (h : ae_measurable f μ) {s : set β} {hfs : ∀ x, f x ∈ s} :
  ae_measurable (cod_restrict f s hfs) μ :=
begin
  nontriviality α, inhabit α,
  obtain ⟨g, g_meas, hg, fg⟩ : ∃ (g : α → β), measurable g ∧ range g ⊆ s ∧ f =ᵐ[μ] g :=
    h.exists_ae_eq_range_subset (eventually_of_forall hfs) ⟨_, hfs default⟩,
  refine ⟨cod_restrict g s (λ x, hg (mem_range_self _)), measurable.subtype_mk g_meas, _⟩,
  filter_upwards [fg] with x hx,
  simpa [subtype.ext_iff],
end

protected lemma null_measurable (h : ae_measurable f μ) : null_measurable f μ :=
let ⟨g, hgm, hg⟩ := h in hgm.null_measurable.congr hg.symm

end ae_measurable

lemma ae_measurable_interval_oc_iff [linear_order α] {f : α → β} {a b : α} :
  (ae_measurable f $ μ.restrict $ Ι a b) ↔
    (ae_measurable f $ μ.restrict $ Ioc a b) ∧ (ae_measurable f $ μ.restrict $ Ioc b a) :=
by rw [interval_oc_eq_union, ae_measurable_union_iff]

lemma ae_measurable_iff_measurable [μ.is_complete] :
  ae_measurable f μ ↔ measurable f :=
⟨λ h, h.null_measurable.measurable_of_complete, λ h, h.ae_measurable⟩

lemma measurable_embedding.ae_measurable_map_iff {g : β → γ} (hf : measurable_embedding f) :
  ae_measurable g (μ.map f) ↔ ae_measurable (g ∘ f) μ :=
begin
  refine ⟨λ H, H.comp_measurable hf.measurable, _⟩,
  rintro ⟨g₁, hgm₁, heq⟩,
  rcases hf.exists_measurable_extend hgm₁ (λ x, ⟨g x⟩) with ⟨g₂, hgm₂, rfl⟩,
  exact ⟨g₂, hgm₂, hf.ae_map_iff.2 heq⟩
end

lemma measurable_embedding.ae_measurable_comp_iff {g : β → γ}
  (hg : measurable_embedding g) {μ : measure α} :
  ae_measurable (g ∘ f) μ ↔ ae_measurable f μ :=
begin
  refine ⟨λ H, _, hg.measurable.comp_ae_measurable⟩,
  suffices : ae_measurable ((range_splitting g ∘ range_factorization g) ∘ f) μ,
    by rwa [(right_inverse_range_splitting hg.injective).comp_eq_id] at this,
  exact hg.measurable_range_splitting.comp_ae_measurable H.subtype_mk
end

lemma ae_measurable_restrict_iff_comap_subtype {s : set α} (hs : measurable_set s)
  {μ : measure α} {f : α → β} :
  ae_measurable f (μ.restrict s) ↔ ae_measurable (f ∘ coe : s → β) (comap coe μ) :=
by rw [← map_comap_subtype_coe hs, (measurable_embedding.subtype_coe hs).ae_measurable_map_iff]

@[simp, to_additive] lemma ae_measurable_one [has_one β] : ae_measurable (λ a : α, (1 : β)) μ :=
measurable_one.ae_measurable

@[simp] lemma ae_measurable_smul_measure_iff {c : ℝ≥0∞} (hc : c ≠ 0) :
  ae_measurable f (c • μ) ↔ ae_measurable f μ :=
⟨λ h, ⟨h.mk f, h.measurable_mk, (ae_smul_measure_iff hc).1 h.ae_eq_mk⟩,
  λ h, ⟨h.mk f, h.measurable_mk, (ae_smul_measure_iff hc).2 h.ae_eq_mk⟩⟩

lemma ae_measurable_of_ae_measurable_trim {α} {m m0 : measurable_space α}
  {μ : measure α} (hm : m ≤ m0) {f : α → β} (hf : ae_measurable f (μ.trim hm)) :
  ae_measurable f μ :=
⟨hf.mk f, measurable.mono hf.measurable_mk hm le_rfl, ae_eq_of_ae_eq_trim hf.ae_eq_mk⟩

lemma ae_measurable_restrict_of_measurable_subtype {s : set α}
  (hs : measurable_set s) (hf : measurable (λ x : s, f x)) : ae_measurable f (μ.restrict s) :=
(ae_measurable_restrict_iff_comap_subtype hs).2 hf.ae_measurable

lemma ae_measurable_map_equiv_iff (e : α ≃ᵐ β) {f : β → γ} :
  ae_measurable f (μ.map e) ↔ ae_measurable (f ∘ e) μ :=
e.measurable_embedding.ae_measurable_map_iff

end

lemma ae_measurable.restrict (hfm : ae_measurable f μ) {s} :
  ae_measurable f (μ.restrict s) :=
⟨ae_measurable.mk f hfm, hfm.measurable_mk, ae_restrict_of_ae hfm.ae_eq_mk⟩

variables [has_zero β]

lemma ae_measurable_indicator_iff {s} (hs : measurable_set s) :
  ae_measurable (indicator s f) μ ↔ ae_measurable f (μ.restrict s) :=
begin
  split,
  { intro h,
    exact (h.mono_measure measure.restrict_le_self).congr (indicator_ae_eq_restrict hs) },
  { intro h,
    refine ⟨indicator s (h.mk f), h.measurable_mk.indicator hs, _⟩,
    have A : s.indicator f =ᵐ[μ.restrict s] s.indicator (ae_measurable.mk f h) :=
      (indicator_ae_eq_restrict hs).trans (h.ae_eq_mk.trans $ (indicator_ae_eq_restrict hs).symm),
    have B : s.indicator f =ᵐ[μ.restrict sᶜ] s.indicator (ae_measurable.mk f h) :=
      (indicator_ae_eq_restrict_compl hs).trans (indicator_ae_eq_restrict_compl hs).symm,
    exact ae_of_ae_restrict_of_ae_restrict_compl _ A B },
end

@[measurability]
lemma ae_measurable.indicator (hfm : ae_measurable f μ) {s} (hs : measurable_set s) :
  ae_measurable (s.indicator f) μ :=
(ae_measurable_indicator_iff hs).mpr hfm.restrict

lemma measure_theory.measure.restrict_map_of_ae_measurable
  {f : α → δ} (hf : ae_measurable f μ) {s : set δ} (hs : measurable_set s) :
  (μ.map f).restrict s = (μ.restrict $ f ⁻¹' s).map f :=
calc
(μ.map f).restrict s = (μ.map (hf.mk f)).restrict s :
  by { congr' 1, apply measure.map_congr hf.ae_eq_mk }
... = (μ.restrict $ (hf.mk f) ⁻¹' s).map (hf.mk f) :
  measure.restrict_map hf.measurable_mk hs
... = (μ.restrict $ (hf.mk f) ⁻¹' s).map f :
  measure.map_congr (ae_restrict_of_ae (hf.ae_eq_mk.symm))
... = (μ.restrict $ f ⁻¹' s).map f :
begin
  apply congr_arg,
  ext1 t ht,
  simp only [ht, measure.restrict_apply],
  apply measure_congr,
  apply (eventually_eq.refl _ _).inter (hf.ae_eq_mk.symm.preimage s)
end

lemma measure_theory.measure.map_mono_of_ae_measurable
  {f : α → δ} (h : μ ≤ ν) (hf : ae_measurable f ν) :
  μ.map f ≤ ν.map f :=
λ s hs, by simpa [hf, hs, hf.mono_measure h] using measure.le_iff'.1 h (f ⁻¹' s)


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

/-!
# Thermodynamic Temperature

This file states
* the axiom that reversible `cycle`s do exists, i.e. `usual_engine_cycle.exists_reversible`
and defines
* thermodynamic temperature of `reservoir`, i.e. `reservoir.temp`
-/

noncomputable theory

namespace thermodynamics

/-!
## Existence of reversible `usual_engine_cycle`
---------------------------------------------------------------------------------------------------/

namespace usual_engine_cycle
variables {𝓗 𝓒 : reservoir} (𝓒_lt_𝓗 : 𝓒 < 𝓗)

axiom exists_reversible : ∃ H : usual_engine_cycle 𝓒_lt_𝓗, H.reversible
copy_doc_string exists_reversible' → exists_reversible

variables {Q : ℝ} (hQ : 0 < Q)
/-- There exists reversible `usual_engine_cycle 𝓒_lt_𝓗` that absorbs a certain heat `Q > 0`. -/
lemma exists_rev_abs : ∃ H : usual_engine_cycle 𝓒_lt_𝓗, H.reversible ∧ ↑H.Qabs = Q :=
  let ⟨H', hH'⟩ := exists_reversible 𝓒_lt_𝓗 in
  let c : ℝ₊ := ⟨Q / H'.Qabs, div_pos hQ H'.do_abs⟩ in
  let H := c • H' in
  ⟨ H,
    cycle.reversible_smul_nonneg (le_of_lt c.property) hH',
    calc ↑H.Qabs
         = Q / H'.Qabs * H'.Qabs : cycle.Qabs_smul_pos c.property
      ...= Q                     : div_mul_cancel _ (ne_of_gt H'.do_abs), ⟩
--

def rev_eff := (classical.some (exists_reversible 𝓒_lt_𝓗)).eff
lemma rev_eff_universal {H : usual_engine_cycle 𝓒_lt_𝓗} (h : H.reversible) :
  H.eff = rev_eff 𝓒_lt_𝓗 := by {
  apply (usual_engine_cycle.rev_iff_eff _).elim_left h,
  exact classical.some_spec (exists_reversible 𝓒_lt_𝓗), }
--

end usual_engine_cycle

-- lemma usual_pump_cycle.exists_reversible

/-!
## Thermodynamic temperature
---------------------------------------------------------------------------------------------------/

/-!
### Construction of thermodynamic temperature
-/

namespace reservoir

section
variables {𝓗 𝓒 : reservoir} (𝓒_lt_𝓗 : 𝓒 < 𝓗)
/-- `temp`erature `corr`elation function -/
@[reducible] def temp_corr := 1 - usual_engine_cycle.rev_eff 𝓒_lt_𝓗
lemma temp_corr_pos    : 0 < temp_corr 𝓒_lt_𝓗 :=
  sub_pos.elim_right (usual_engine_cycle.eff_lt_one _)
lemma temp_corr_lt_one : temp_corr 𝓒_lt_𝓗 < 1 :=
  sub_lt_self _ (cycle.eff_pos _)
lemma temp_corr_eq_Qratio {H : usual_engine_cycle 𝓒_lt_𝓗} (hH : H.reversible) :
  temp_corr 𝓒_lt_𝓗 = H.Qrel / H.Qabs :=
  calc temp_corr 𝓒_lt_𝓗
       = 1 - H.eff : by rw [usual_engine_cycle.rev_eff_universal _ hH]
    ...= H.Qrel / H.Qabs : by { rw H.eff_from_Qabs_Qrel, ring }
end

section
variables {𝓐 𝓑 𝓒 : reservoir} (𝓒_lt_𝓑 : 𝓒 < 𝓑) (𝓑_lt_𝓐 : 𝓑 < 𝓐)
theorem temp_corr_trans :
  temp_corr (𝓒_lt_𝓑.trans 𝓑_lt_𝓐) = (temp_corr 𝓒_lt_𝓑) * (temp_corr 𝓑_lt_𝓐) :=
  let 𝓒_lt_𝓐 := 𝓒_lt_𝓑.trans 𝓑_lt_𝓐 in
  let ⟨H𝓐𝓑, hH𝓐𝓑⟩ := usual_engine_cycle.exists_reversible 𝓑_lt_𝓐 in
  let ⟨H𝓑𝓒, hH𝓑𝓒, hQ⟩ := usual_engine_cycle.exists_rev_abs 𝓒_lt_𝓑 H𝓐𝓑.do_rel in by {
  let H𝓐𝓒' := H𝓐𝓑.to_cycle + H𝓑𝓒.to_cycle,
  have H𝓑𝓒_no𝓐 : 𝓐 ∉ H𝓑𝓒.𝓠.support, {
    rw H𝓑𝓒.two_rsv.elim_left,
    simp only [finset.mem_insert, finset.mem_singleton, not_or_distrib],
    exact ⟨ne_of_gt 𝓑_lt_𝓐, ne_of_gt 𝓒_lt_𝓐⟩, },
  have H𝓐𝓑_no𝓒 : 𝓒 ∉ H𝓐𝓑.𝓠.support, {
    rw H𝓐𝓑.two_rsv.elim_left,
    simp only [finset.mem_insert, finset.mem_singleton, not_or_distrib],
    exact ⟨ne_of_lt 𝓒_lt_𝓐, ne_of_lt 𝓒_lt_𝓑⟩, },
  have H𝓐𝓒'Qabs :=
    calc H𝓐𝓒'.𝓠 𝓐
         = H𝓐𝓑.𝓠 𝓐 + H𝓑𝓒.𝓠 𝓐 : rfl
      ...= H𝓐𝓑.𝓠 𝓐            : by rw [finsupp.not_mem_support_iff.elim_left H𝓑𝓒_no𝓐, add_zero]
      ...= H𝓐𝓑.Qabs            : H𝓐𝓑.Qabs_one_rsv.symm,
  have H𝓐𝓒'Qrel :=
    calc H𝓐𝓒'.𝓠 𝓒
         = H𝓐𝓑.𝓠 𝓒 + H𝓑𝓒.𝓠 𝓒 : rfl
      ...=            H𝓑𝓒.𝓠 𝓒 : by rw [finsupp.not_mem_support_iff.elim_left H𝓐𝓑_no𝓒, zero_add]
      ...=           -H𝓑𝓒.Qrel : by rw [←neg_neg (H𝓑𝓒.𝓠 𝓒), ←H𝓑𝓒.Qrel_one_rsv],
  have do_abs_rsv : H𝓐𝓒'.𝓠 𝓐 > 0, from H𝓐𝓒'Qabs.symm ▸ H𝓐𝓑.do_abs,
  have do_rel_rsv : H𝓐𝓒'.𝓠 𝓒 < 0, {
    rw H𝓐𝓒'Qrel,
    exact neg_lt_zero.elim_right H𝓑𝓒.do_rel, },
  let H𝓐𝓒 : usual_engine_cycle 𝓒_lt_𝓐 :=
    { two_rsv := by {
        refine ⟨_, ne_of_gt 𝓒_lt_𝓐⟩,
        have : H𝓐𝓒'.𝓠 = H𝓐𝓑.𝓠 + H𝓑𝓒.𝓠, from rfl, rw this,
        apply finsupp.support_add_exact,
        { simp only [finset.mem_insert, finset.mem_singleton, ne.def, forall_eq_or_imp, forall_eq],
          split,
            exact ne_of_gt do_abs_rsv,
            exact ne_of_lt do_rel_rsv, },
        { have : (H𝓐𝓑.𝓠.support ∪ H𝓑𝓒.𝓠.support) \ {𝓐, 𝓒} = {𝓑}, {
            rw [H𝓐𝓑.two_rsv.elim_left, H𝓑𝓒.two_rsv.elim_left],
            ext, simp, split,
            { tauto, },
            { assume h𝓑,
              split,
              { exact or.inl h𝓑, },
              { rw [not_or_distrib, h𝓑],
                exact ⟨ne_of_lt 𝓑_lt_𝓐, ne_of_gt 𝓒_lt_𝓑⟩, } } },
          simp only [this, finset.mem_singleton, forall_eq],
          calc H𝓐𝓑.𝓠 𝓑 + H𝓑𝓒.𝓠 𝓑
               = -H𝓐𝓑.Qrel + H𝓑𝓒.Qabs : by rw [H𝓐𝓑.Qrel_one_rsv, neg_neg, H𝓑𝓒.Qabs_one_rsv]
            ...= 0                     : by { rw hQ, ring }, } },
      do_abs_rsv := do_abs_rsv,
      do_rel_rsv := do_rel_rsv,
      do_work :=
        calc H𝓐𝓒'.𝓦
             = H𝓐𝓑.𝓦 + H𝓑𝓒.𝓦 : cycle.𝓦_add
          ...> 0                : add_pos H𝓐𝓑.do_work H𝓑𝓒.do_work,
      ..H𝓐𝓒' },
  have := temp_corr_eq_Qratio 𝓑_lt_𝓐 hH𝓐𝓑, rw this,
  have := temp_corr_eq_Qratio 𝓒_lt_𝓑 hH𝓑𝓒, rw this,
  rw [hQ, div_mul_div_cancel _ (ne_of_gt H𝓐𝓑.do_rel)],
  have : H𝓐𝓒.reversible, from cycle.reversible_add hH𝓐𝓑 hH𝓑𝓒,
  have := temp_corr_eq_Qratio 𝓒_lt_𝓐 this, rw this,
  rw [H𝓐𝓒.Qabs_one_rsv, H𝓐𝓒'Qabs],
  rw [H𝓐𝓒.Qrel_one_rsv, H𝓐𝓒'Qrel, neg_neg], }
/-- `temp_corr 𝓒_lt_𝓗` is `strict_mono` as a function of `𝓒` -/
lemma temp_corr_strict_mono : temp_corr (𝓒_lt_𝓑.trans 𝓑_lt_𝓐) < temp_corr 𝓑_lt_𝓐 := by {
  rw temp_corr_trans 𝓒_lt_𝓑 𝓑_lt_𝓐,
  exact (mul_lt_iff_lt_one_left (temp_corr_pos _)).elim_right (temp_corr_lt_one _), }
end

/-- `ref`erence `sys`tem -/
@[reducible] def ref_sys : equil_system := water_triple_point
/-- reference temperature of `ref_sys` -/
@[reducible] def ref_temp : ℝ₊ := ⟨273.16, by cancel_denoms⟩
/-- thermodynamic `temp`erature of `reservoir`s -/
def temp : reservoir ↪o ℝ₊ := order_embedding.of_strict_mono
  ( λ 𝓣,
    if        heq : 𝓣 = ⟦ref_sys⟧ then
      ref_temp
    else if   hlt : 𝓣 < ⟦ref_sys⟧ then
      ⟨(temp_corr hlt) * ref_temp, mul_pos (temp_corr_pos _) ref_temp.property⟩
    else have hgt : 𝓣 > ⟦ref_sys⟧, from ne.lt_of_le' heq (le_of_not_gt hlt),
      ⟨ref_temp / (temp_corr hgt), div_pos ref_temp.property (temp_corr_pos _)⟩ )
  ( assume 𝓒 𝓗 𝓒_lt_𝓗,
    if        h𝓗lt : 𝓗 < ⟦ref_sys⟧ then by {
      have h𝓒lt := 𝓒_lt_𝓗.trans h𝓗lt,
      simp only [ne_of_lt h𝓒lt, h𝓒lt, ne_of_lt h𝓗lt, h𝓗lt,
        dif_pos, dite_eq_ite, if_false],
      refine mul_lt_mul _ (le_rfl) (ref_temp.property) (le_of_lt (temp_corr_pos _)),
      exact temp_corr_strict_mono 𝓒_lt_𝓗 h𝓗lt, }
    else if   h𝓗eq : 𝓗 = ⟦ref_sys⟧ then by {
      have h𝓒lt : 𝓒 < ⟦ref_sys⟧, from h𝓗eq ▸ 𝓒_lt_𝓗,
      simp only [ne_of_lt h𝓒lt, h𝓒lt, h𝓗eq,
        dif_pos, not_false_iff, dif_neg],
      exact (mul_lt_iff_lt_one_left ref_temp.property).elim_right (temp_corr_lt_one _), }
    else have h𝓗gt : 𝓗 > ⟦ref_sys⟧, from
        ne.lt_of_le (ne.symm h𝓗eq) (le_of_not_gt h𝓗lt), by {
      simp only [ne_of_gt h𝓗gt, not_lt_of_gt h𝓗gt,
        not_false_iff, dif_neg],
      apply subtype.coe_lt_coe.elim_left,
      rw [subtype.coe_mk (↑ref_temp / temp_corr h𝓗gt) _, div_eq_mul_one_div],
      exact if  h𝓒lt : 𝓒 < ⟦ref_sys⟧ then by {
        simp only [ne_of_lt h𝓒lt, h𝓒lt,
          dif_pos, dite_eq_ite, if_false],
        rw [subtype.coe_mk, mul_comm (temp_corr h𝓒lt) _],
        refine mul_lt_mul' (le_rfl) _ (le_of_lt (temp_corr_pos _)) (ref_temp.property),
          apply (lt_div_iff (temp_corr_pos _)).elim_right,
          rw ←temp_corr_trans,
          exact temp_corr_lt_one _, }
      else if   h𝓒eq : 𝓒 = ⟦ref_sys⟧ then by {
        simp only [h𝓒eq, dif_pos],
        apply lt_mul_right ref_temp.property,
          apply (lt_div_iff (temp_corr_pos _)).elim_right,
          rw one_mul,
          exact temp_corr_lt_one _, }
      else have h𝓒gt : 𝓒 > ⟦ref_sys⟧, from
          ne.lt_of_le (ne.symm h𝓒eq) (le_of_not_gt h𝓒lt), by {
        simp only [ne_of_gt h𝓒gt, not_lt_of_gt h𝓒gt,
          not_false_iff, dif_neg],
        rw [subtype.coe_mk, div_eq_mul_one_div _ (temp_corr h𝓒gt)],
        refine mul_lt_mul' (le_rfl) _ _ (ref_temp.property),
        { apply (one_div_lt_one_div (temp_corr_pos _) (temp_corr_pos _)).elim_right,
          rw temp_corr_trans h𝓒gt 𝓒_lt_𝓗,
          exact (mul_lt_iff_lt_one_right (temp_corr_pos _)).elim_right (temp_corr_lt_one _), },
        { exact div_nonneg zero_le_one (le_of_lt (temp_corr_pos _)), } } } )
--

end reservoir

/-!
### Applications of thermodynamic temperature
-/

/- namespace usual_engine_cycle
variables {𝓗 𝓒 : reservoir} (𝓒_lt_𝓗 : 𝓒 < 𝓗)

lemma rev_eff_from_temp : rev_eff 𝓒_lt_𝓗 = 1 - 𝓒.temp / 𝓗.temp := sorry

end usual_engine_cycle -/

/-!
## The absolute zero

TODO
* existence of the absolute zero as a limit ?
* require `rsv_no_min` ?
* behavior of `usual_engine_cycle` when 𝓒.temp -> 0
---------------------------------------------------------------------------------------------------/

end thermodynamics


/-
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

! This file was ported from Lean 3 source module deprecated.submonoid
! leanprover-community/mathlib commit a11f9106a169dd302a285019e5165f8ab32ff433
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.GroupTheory.Submonoid.Basic
import Mathbin.Algebra.BigOperators.Basic
import Mathbin.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 BigOperators

variable {M : Type _} [Monoid M] {s : Set M}

variable {A : Type _} [AddMonoid A] {t : Set A}

#print IsAddSubmonoid /-
/-- `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 IsAddSubmonoid (s : Set A) : Prop where
  zero_mem : (0 : A) ∈ s
  add_mem {a b} : a ∈ s → b ∈ s → a + b ∈ s
#align is_add_submonoid IsAddSubmonoid
-/

#print IsSubmonoid /-
/-- `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 IsSubmonoid (s : Set M) : Prop where
  one_mem : (1 : M) ∈ s
  mul_mem {a b} : a ∈ s → b ∈ s → a * b ∈ s
#align is_submonoid IsSubmonoid
#align is_add_submonoid IsAddSubmonoid
-/

#print Additive.isAddSubmonoid /-
theorem Additive.isAddSubmonoid {s : Set M} : ∀ is : IsSubmonoid s, @IsAddSubmonoid (Additive M) _ s
  | ⟨h₁, h₂⟩ => ⟨h₁, @h₂⟩
#align additive.is_add_submonoid Additive.isAddSubmonoid
-/

#print Additive.isAddSubmonoid_iff /-
theorem Additive.isAddSubmonoid_iff {s : Set M} :
    @IsAddSubmonoid (Additive M) _ s ↔ IsSubmonoid s :=
  ⟨fun ⟨h₁, h₂⟩ => ⟨h₁, @h₂⟩, Additive.isAddSubmonoid⟩
#align additive.is_add_submonoid_iff Additive.isAddSubmonoid_iff
-/

#print Multiplicative.isSubmonoid /-
theorem Multiplicative.isSubmonoid {s : Set A} :
    ∀ is : IsAddSubmonoid s, @IsSubmonoid (Multiplicative A) _ s
  | ⟨h₁, h₂⟩ => ⟨h₁, @h₂⟩
#align multiplicative.is_submonoid Multiplicative.isSubmonoid
-/

#print Multiplicative.isSubmonoid_iff /-
theorem Multiplicative.isSubmonoid_iff {s : Set A} :
    @IsSubmonoid (Multiplicative A) _ s ↔ IsAddSubmonoid s :=
  ⟨fun ⟨h₁, h₂⟩ => ⟨h₁, @h₂⟩, Multiplicative.isSubmonoid⟩
#align multiplicative.is_submonoid_iff Multiplicative.isSubmonoid_iff
-/

/- warning: is_submonoid.inter -> IsSubmonoid.inter is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} [_inst_1 : Monoid.{u1} M] {s₁ : Set.{u1} M} {s₂ : Set.{u1} M}, (IsSubmonoid.{u1} M _inst_1 s₁) -> (IsSubmonoid.{u1} M _inst_1 s₂) -> (IsSubmonoid.{u1} M _inst_1 (Inter.inter.{u1} (Set.{u1} M) (Set.hasInter.{u1} M) s₁ s₂))
but is expected to have type
  forall {M : Type.{u1}} [_inst_1 : Monoid.{u1} M] {s₁ : Set.{u1} M} {s₂ : Set.{u1} M}, (IsSubmonoid.{u1} M _inst_1 s₁) -> (IsSubmonoid.{u1} M _inst_1 s₂) -> (IsSubmonoid.{u1} M _inst_1 (Inter.inter.{u1} (Set.{u1} M) (Set.instInterSet.{u1} M) s₁ s₂))
Case conversion may be inaccurate. Consider using '#align is_submonoid.inter IsSubmonoid.interₓ'. -/
/-- 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\nan `add_submonoid` of M."]
theorem IsSubmonoid.inter {s₁ s₂ : Set M} (is₁ : IsSubmonoid s₁) (is₂ : IsSubmonoid s₂) :
    IsSubmonoid (s₁ ∩ s₂) :=
  { one_mem := ⟨is₁.one_mem, is₂.one_mem⟩
    mul_mem := fun x y hx hy => ⟨is₁.mul_mem hx.1 hy.1, is₂.mul_mem hx.2 hy.2⟩ }
#align is_submonoid.inter IsSubmonoid.inter
#align is_add_submonoid.inter IsAddSubmonoid.inter

#print IsSubmonoid.interᵢ /-
/-- 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\nan `add_submonoid` of `M`."]
theorem IsSubmonoid.interᵢ {ι : Sort _} {s : ι → Set M} (h : ∀ y : ι, IsSubmonoid (s y)) :
    IsSubmonoid (Set.interᵢ s) :=
  { one_mem := Set.mem_interᵢ.2 fun y => (h y).one_mem
    mul_mem := fun x₁ x₂ h₁ h₂ =>
      Set.mem_interᵢ.2 fun y => (h y).mul_mem (Set.mem_interᵢ.1 h₁ y) (Set.mem_interᵢ.1 h₂ y) }
#align is_submonoid.Inter IsSubmonoid.interᵢ
#align is_add_submonoid.Inter IsAddSubmonoid.interᵢ
-/

#print isSubmonoid_unionᵢ_of_directed /-
/-- 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\nof `add_submonoid`s of an `add_monoid` `M` is an `add_submonoid` of `M`. "]
theorem isSubmonoid_unionᵢ_of_directed {ι : Type _} [hι : Nonempty ι] {s : ι → Set M}
    (hs : ∀ i, IsSubmonoid (s i)) (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
    IsSubmonoid (⋃ i, s i) :=
  { one_mem :=
      let ⟨i⟩ := hι
      Set.mem_unionᵢ.2 ⟨i, (hs i).one_mem⟩
    mul_mem := fun a b ha hb =>
      let ⟨i, hi⟩ := Set.mem_unionᵢ.1 ha
      let ⟨j, hj⟩ := Set.mem_unionᵢ.1 hb
      let ⟨k, hk⟩ := Directed i j
      Set.mem_unionᵢ.2 ⟨k, (hs k).mul_mem (hk.1 hi) (hk.2 hj)⟩ }
#align is_submonoid_Union_of_directed isSubmonoid_unionᵢ_of_directed
#align is_add_submonoid_Union_of_directed isAddSubmonoid_unionᵢ_of_directed
-/

section powers

#print 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 }
#align powers powers
#align multiples multiples
-/

/- warning: powers.one_mem -> powers.one_mem is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} [_inst_1 : Monoid.{u1} M] {x : M}, Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) (OfNat.ofNat.{u1} M 1 (OfNat.mk.{u1} M 1 (One.one.{u1} M (MulOneClass.toHasOne.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))))) (powers.{u1} M _inst_1 x)
but is expected to have type
  forall {M : Type.{u1}} [_inst_1 : Monoid.{u1} M] {x : M}, Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) (OfNat.ofNat.{u1} M 1 (One.toOfNat1.{u1} M (Monoid.toOne.{u1} M _inst_1))) (powers.{u1} M _inst_1 x)
Case conversion may be inaccurate. Consider using '#align powers.one_mem powers.one_memₓ'. -/
/-- 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`."]
theorem powers.one_mem {x : M} : (1 : M) ∈ powers x :=
  ⟨0, pow_zero _⟩
#align powers.one_mem powers.one_mem
#align multiples.zero_mem multiples.zero_mem

#print powers.self_mem /-
/-- 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."]
theorem powers.self_mem {x : M} : x ∈ powers x :=
  ⟨1, pow_one _⟩
#align powers.self_mem powers.self_mem
#align multiples.self_mem multiples.self_mem
-/

/- warning: powers.mul_mem -> powers.mul_mem is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} [_inst_1 : Monoid.{u1} M] {x : M} {y : M} {z : M}, (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) y (powers.{u1} M _inst_1 x)) -> (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) z (powers.{u1} M _inst_1 x)) -> (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toHasMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) y z) (powers.{u1} M _inst_1 x))
but is expected to have type
  forall {M : Type.{u1}} [_inst_1 : Monoid.{u1} M] {x : M} {y : M} {z : M}, (Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) y (powers.{u1} M _inst_1 x)) -> (Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) z (powers.{u1} M _inst_1 x)) -> (Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) y z) (powers.{u1} M _inst_1 x))
Case conversion may be inaccurate. Consider using '#align powers.mul_mem powers.mul_memₓ'. -/
/-- 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."]
theorem powers.mul_mem {x y z : M} : y ∈ powers x → z ∈ powers x → y * z ∈ powers x :=
  fun ⟨n₁, h₁⟩ ⟨n₂, h₂⟩ => ⟨n₁ + n₂, by simp only [pow_add, *]⟩
#align powers.mul_mem powers.mul_mem
#align multiples.add_mem multiples.add_mem

#print powers.isSubmonoid /-
/-- 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\nan `add_monoid` `M` is an `add_submonoid` of `M`."]
theorem powers.isSubmonoid (x : M) : IsSubmonoid (powers x) :=
  { one_mem := powers.one_mem
    mul_mem := fun y z => powers.mul_mem }
#align powers.is_submonoid powers.isSubmonoid
#align multiples.is_add_submonoid multiples.isAddSubmonoid
-/

#print Univ.isSubmonoid /-
/-- A monoid is a submonoid of itself. -/
@[to_additive "An `add_monoid` is an `add_submonoid` of itself."]
theorem Univ.isSubmonoid : IsSubmonoid (@Set.univ M) := by constructor <;> simp
#align univ.is_submonoid Univ.isSubmonoid
#align univ.is_add_submonoid Univ.isAddSubmonoid
-/

#print IsSubmonoid.preimage /-
/-- 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\nan `add_submonoid` of the domain."]
theorem IsSubmonoid.preimage {N : Type _} [Monoid N] {f : M → N} (hf : IsMonoidHom f) {s : Set N}
    (hs : IsSubmonoid s) : IsSubmonoid (f ⁻¹' s) :=
  { one_mem := show f 1 ∈ s by rw [IsMonoidHom.map_one hf] <;> exact hs.one_mem
    mul_mem := fun a b (ha : f a ∈ s) (hb : f b ∈ s) =>
      show f (a * b) ∈ s by rw [IsMonoidHom.map_mul' hf] <;> exact hs.mul_mem ha hb }
#align is_submonoid.preimage IsSubmonoid.preimage
#align is_add_submonoid.preimage IsAddSubmonoid.preimage
-/

#print IsSubmonoid.image /-
/-- 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`\nhom is an `add_submonoid` of the codomain."]
theorem IsSubmonoid.image {γ : Type _} [Monoid γ] {f : M → γ} (hf : IsMonoidHom f) {s : Set M}
    (hs : IsSubmonoid s) : IsSubmonoid (f '' s) :=
  { one_mem := ⟨1, hs.one_mem, hf.map_one⟩
    mul_mem := fun a b ⟨x, hx⟩ ⟨y, hy⟩ =>
      ⟨x * y, hs.mul_mem hx.1 hy.1, by rw [hf.map_mul, hx.2, hy.2]⟩ }
#align is_submonoid.image IsSubmonoid.image
#align is_add_submonoid.image IsAddSubmonoid.image
-/

#print Range.isSubmonoid /-
/-- 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`\nof the codomain."]
theorem Range.isSubmonoid {γ : Type _} [Monoid γ] {f : M → γ} (hf : IsMonoidHom f) :
    IsSubmonoid (Set.range f) := by
  rw [← Set.image_univ]
  exact univ.is_submonoid.image hf
#align range.is_submonoid Range.isSubmonoid
#align range.is_add_submonoid Range.isAddSubmonoid
-/

#print IsSubmonoid.pow_mem /-
/-- Submonoids are closed under natural powers. -/
@[to_additive IsAddSubmonoid.smul_mem
      "An `add_submonoid` is closed under multiplication by naturals."]
theorem IsSubmonoid.pow_mem {a : M} (hs : IsSubmonoid 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 IsSubmonoid.pow_mem
#align is_submonoid.pow_mem IsSubmonoid.pow_mem
-/

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

end powers

namespace IsSubmonoid

/- warning: is_submonoid.list_prod_mem -> IsSubmonoid.list_prod_mem is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} [_inst_1 : Monoid.{u1} M] {s : Set.{u1} M}, (IsSubmonoid.{u1} M _inst_1 s) -> (forall {l : List.{u1} M}, (forall (x : M), (Membership.Mem.{u1, u1} M (List.{u1} M) (List.hasMem.{u1} M) x l) -> (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) x s)) -> (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) (List.prod.{u1} M (MulOneClass.toHasMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (MulOneClass.toHasOne.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) l) s))
but is expected to have type
  forall {M : Type.{u1}} [_inst_1 : Monoid.{u1} M] {s : Set.{u1} M}, (IsSubmonoid.{u1} M _inst_1 s) -> (forall {l : List.{u1} M}, (forall (x : M), (Membership.mem.{u1, u1} M (List.{u1} M) (List.instMembershipList.{u1} M) x l) -> (Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) x s)) -> (Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) (List.prod.{u1} M (MulOneClass.toMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (Monoid.toOne.{u1} M _inst_1) l) s))
Case conversion may be inaccurate. Consider using '#align is_submonoid.list_prod_mem IsSubmonoid.list_prod_memₓ'. -/
/-- 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\n`add_submonoid`."]
theorem list_prod_mem (hs : IsSubmonoid 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)
#align is_submonoid.list_prod_mem IsSubmonoid.list_prod_mem
#align is_add_submonoid.list_sum_mem IsAddSubmonoid.list_sum_mem

#print IsSubmonoid.multiset_prod_mem /-
/-- 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`\nis an element of the `add_submonoid`. "]
theorem multiset_prod_mem {M} [CommMonoid M] {s : Set M} (hs : IsSubmonoid s) (m : Multiset M) :
    (∀ a ∈ m, a ∈ s) → m.Prod ∈ s :=
  by
  refine' Quotient.inductionOn m fun l hl => _
  rw [Multiset.quot_mk_to_coe, Multiset.coe_prod]
  exact list_prod_mem hs hl
#align is_submonoid.multiset_prod_mem IsSubmonoid.multiset_prod_mem
#align is_add_submonoid.multiset_sum_mem IsAddSubmonoid.multiset_sum_mem
-/

/- warning: is_submonoid.finset_prod_mem -> IsSubmonoid.finset_prod_mem is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} {A : Type.{u2}} [_inst_3 : CommMonoid.{u1} M] {s : Set.{u1} M}, (IsSubmonoid.{u1} M (CommMonoid.toMonoid.{u1} M _inst_3) s) -> (forall (f : A -> M) (t : Finset.{u2} A), (forall (b : A), (Membership.Mem.{u2, u2} A (Finset.{u2} A) (Finset.hasMem.{u2} A) b t) -> (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) (f b) s)) -> (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) (Finset.prod.{u1, u2} M A _inst_3 t (fun (b : A) => f b)) s))
but is expected to have type
  forall {M : Type.{u2}} {A : Type.{u1}} [_inst_3 : CommMonoid.{u2} M] {s : Set.{u2} M}, (IsSubmonoid.{u2} M (CommMonoid.toMonoid.{u2} M _inst_3) s) -> (forall (f : A -> M) (t : Finset.{u1} A), (forall (b : A), (Membership.mem.{u1, u1} A (Finset.{u1} A) (Finset.instMembershipFinset.{u1} A) b t) -> (Membership.mem.{u2, u2} M (Set.{u2} M) (Set.instMembershipSet.{u2} M) (f b) s)) -> (Membership.mem.{u2, u2} M (Set.{u2} M) (Set.instMembershipSet.{u2} M) (Finset.prod.{u2, u1} M A _inst_3 t (fun (b : A) => f b)) s))
Case conversion may be inaccurate. Consider using '#align is_submonoid.finset_prod_mem IsSubmonoid.finset_prod_memₓ'. -/
/-- 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\na `finset` is an element of the `add_submonoid`."]
theorem finset_prod_mem {M A} [CommMonoid M] {s : Set M} (hs : IsSubmonoid 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)
#align is_submonoid.finset_prod_mem IsSubmonoid.finset_prod_mem
#align is_add_submonoid.finset_sum_mem IsAddSubmonoid.finset_sum_mem

end IsSubmonoid

namespace AddMonoid

#print AddMonoid.InClosure /-
/-- The inductively defined membership predicate for the submonoid generated by a subset of a
    monoid. -/
inductive InClosure (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)
#align add_monoid.in_closure AddMonoid.InClosure
-/

end AddMonoid

namespace Monoid

#print Monoid.InClosure /-
/-- The inductively defined membership predicate for the `submonoid` generated by a subset of an
    monoid. -/
@[to_additive]
inductive InClosure (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)
#align monoid.in_closure Monoid.InClosure
#align add_monoid.in_closure AddMonoid.InClosure
-/

#print Monoid.Closure /-
/-- 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 | InClosure s a }
#align monoid.closure Monoid.Closure
#align add_monoid.closure AddMonoid.Closure
-/

#print Monoid.closure.isSubmonoid /-
@[to_additive]
theorem closure.isSubmonoid (s : Set M) : IsSubmonoid (Closure s) :=
  { one_mem := InClosure.one
    mul_mem := fun a b => InClosure.mul }
#align monoid.closure.is_submonoid Monoid.closure.isSubmonoid
#align add_monoid.closure.is_add_submonoid AddMonoid.closure.isAddSubmonoid
-/

#print Monoid.subset_closure /-
/-- 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 := fun a => InClosure.basic
#align monoid.subset_closure Monoid.subset_closure
#align add_monoid.subset_closure AddMonoid.subset_closure
-/

#print Monoid.closure_subset /-
/-- 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\ncontains the set."]
theorem closure_subset {s t : Set M} (ht : IsSubmonoid t) (h : s ⊆ t) : Closure s ⊆ t := fun a ha =>
  by induction ha <;> simp [h _, *, IsSubmonoid.one_mem, IsSubmonoid.mul_mem]
#align monoid.closure_subset Monoid.closure_subset
#align add_monoid.closure_subset AddMonoid.closure_subset
-/

#print Monoid.closure_mono /-
/-- 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`\nof `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.isSubmonoid t) <| Set.Subset.trans h subset_closure
#align monoid.closure_mono Monoid.closure_mono
#align add_monoid.closure_mono AddMonoid.closure_mono
-/

#print Monoid.closure_singleton /-
/-- 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\nnatural 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.isSubmonoid x) <| Set.singleton_subset_iff.2 <| powers.self_mem) <|
    IsSubmonoid.power_subset (closure.isSubmonoid _) <| Set.singleton_subset_iff.1 <| subset_closure
#align monoid.closure_singleton Monoid.closure_singleton
#align add_monoid.closure_singleton AddMonoid.closure_singleton
-/

#print Monoid.image_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\nthe `add_submonoid` generated by the image of the set under the `add_monoid` hom."]
theorem image_closure {A : Type _} [Monoid A] {f : M → A} (hf : IsMonoidHom f) (s : Set M) :
    f '' Closure s = Closure (f '' s) :=
  le_antisymm
    (by
      rintro _ ⟨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 IsSubmonoid.one_mem (closure.is_submonoid (f '' s))
      · rw [hf.map_mul]
        solve_by_elim [(closure.is_submonoid _).mul_mem] )
    (closure_subset (IsSubmonoid.image hf (closure.isSubmonoid _)) <|
      Set.image_subset _ subset_closure)
#align monoid.image_closure Monoid.image_closure
#align add_monoid.image_closure AddMonoid.image_closure
-/

/- warning: monoid.exists_list_of_mem_closure -> Monoid.exists_list_of_mem_closure is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} [_inst_1 : Monoid.{u1} M] {s : Set.{u1} M} {a : M}, (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) a (Monoid.Closure.{u1} M _inst_1 s)) -> (Exists.{succ u1} (List.{u1} M) (fun (l : List.{u1} M) => And (forall (x : M), (Membership.Mem.{u1, u1} M (List.{u1} M) (List.hasMem.{u1} M) x l) -> (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) x s)) (Eq.{succ u1} M (List.prod.{u1} M (MulOneClass.toHasMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (MulOneClass.toHasOne.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) l) a)))
but is expected to have type
  forall {M : Type.{u1}} [_inst_1 : Monoid.{u1} M] {s : Set.{u1} M} {a : M}, (Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) a (Monoid.Closure.{u1} M _inst_1 s)) -> (Exists.{succ u1} (List.{u1} M) (fun (l : List.{u1} M) => And (forall (x : M), (Membership.mem.{u1, u1} M (List.{u1} M) (List.instMembershipList.{u1} M) x l) -> (Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) x s)) (Eq.{succ u1} M (List.prod.{u1} M (MulOneClass.toMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (Monoid.toOne.{u1} M _inst_1) l) a)))
Case conversion may be inaccurate. Consider using '#align monoid.exists_list_of_mem_closure Monoid.exists_list_of_mem_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\na 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 :=
  by
  induction h
  case basic a ha => exists [a]; simp [ha]
  case one => exists []; simp
  case mul a b _ _ ha hb =>
    rcases ha with ⟨la, ha, eqa⟩
    rcases hb with ⟨lb, hb, eqb⟩
    exists la ++ lb
    simp [eqa.symm, eqb.symm, or_imp]
    exact fun a => ⟨ha a, hb a⟩
#align monoid.exists_list_of_mem_closure Monoid.exists_list_of_mem_closure
#align add_monoid.exists_list_of_mem_closure AddMonoid.exists_list_of_mem_closure

/- warning: monoid.mem_closure_union_iff -> Monoid.mem_closure_union_iff is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} [_inst_3 : CommMonoid.{u1} M] {s : Set.{u1} M} {t : Set.{u1} M} {x : M}, Iff (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) x (Monoid.Closure.{u1} M (CommMonoid.toMonoid.{u1} M _inst_3) (Union.union.{u1} (Set.{u1} M) (Set.hasUnion.{u1} M) s t))) (Exists.{succ u1} M (fun (y : M) => Exists.{0} (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) y (Monoid.Closure.{u1} M (CommMonoid.toMonoid.{u1} M _inst_3) s)) (fun (H : Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) y (Monoid.Closure.{u1} M (CommMonoid.toMonoid.{u1} M _inst_3) s)) => Exists.{succ u1} M (fun (z : M) => Exists.{0} (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) z (Monoid.Closure.{u1} M (CommMonoid.toMonoid.{u1} M _inst_3) t)) (fun (H : Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) z (Monoid.Closure.{u1} M (CommMonoid.toMonoid.{u1} M _inst_3) t)) => Eq.{succ u1} M (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toHasMul.{u1} M (Monoid.toMulOneClass.{u1} M (CommMonoid.toMonoid.{u1} M _inst_3)))) y z) x)))))
but is expected to have type
  forall {M : Type.{u1}} [_inst_3 : CommMonoid.{u1} M] {s : Set.{u1} M} {t : Set.{u1} M} {x : M}, Iff (Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) x (Monoid.Closure.{u1} M (CommMonoid.toMonoid.{u1} M _inst_3) (Union.union.{u1} (Set.{u1} M) (Set.instUnionSet.{u1} M) s t))) (Exists.{succ u1} M (fun (y : M) => And (Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) y (Monoid.Closure.{u1} M (CommMonoid.toMonoid.{u1} M _inst_3) s)) (Exists.{succ u1} M (fun (z : M) => And (Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) z (Monoid.Closure.{u1} M (CommMonoid.toMonoid.{u1} M _inst_3) t)) (Eq.{succ u1} M (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toMul.{u1} M (Monoid.toMulOneClass.{u1} M (CommMonoid.toMonoid.{u1} M _inst_3)))) y z) x)))))
Case conversion may be inaccurate. Consider using '#align monoid.mem_closure_union_iff Monoid.mem_closure_union_iffₓ'. -/
/-- 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`\nof `M` generated by `s ∪ t` iff there exists an element of the `add_submonoid` generated by `s`\nand an element of the `add_submonoid` generated by `t` whose sum is `x`."]
theorem mem_closure_union_iff {M : Type _} [CommMonoid M] {s t : Set M} {x : M} :
    x ∈ Closure (s ∪ t) ↔ ∃ y ∈ Closure s, ∃ z ∈ Closure t, y * z = x :=
  ⟨fun hx =>
    let ⟨L, HL1, HL2⟩ := exists_list_of_mem_closure hx
    HL2 ▸
      List.recOn L
        (fun _ =>
          ⟨1, (closure.isSubmonoid _).one_mem, 1, (closure.isSubmonoid _).one_mem, mul_one _⟩)
        (fun hd tl ih HL1 =>
          let ⟨y, hy, z, hz, hyzx⟩ := ih (List.forall_mem_of_forall_mem_cons HL1)
          Or.cases_on (HL1 hd <| List.mem_cons_self _ _)
            (fun hs =>
              ⟨hd * y, (closure.isSubmonoid _).mul_mem (subset_closure hs) hy, z, hz, by
                rw [mul_assoc, List.prod_cons, ← hyzx] <;> rfl⟩)
            fun ht =>
            ⟨y, hy, z * hd, (closure.isSubmonoid _).mul_mem hz (subset_closure ht), by
              rw [← mul_assoc, List.prod_cons, ← hyzx, mul_comm hd] <;> rfl⟩)
        HL1,
    fun ⟨y, hy, z, hz, hyzx⟩ =>
    hyzx ▸
      (closure.isSubmonoid _).mul_mem (closure_mono (Set.subset_union_left _ _) hy)
        (closure_mono (Set.subset_union_right _ _) hz)⟩
#align monoid.mem_closure_union_iff Monoid.mem_closure_union_iff
#align add_monoid.mem_closure_union_iff AddMonoid.mem_closure_union_iff

end Monoid

#print Submonoid.of /-
/-- 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 : IsSubmonoid s) : Submonoid M :=
  ⟨s, fun _ _ => h.2, h.1⟩
#align submonoid.of Submonoid.of
#align add_submonoid.of AddSubmonoid.of
-/

/- warning: submonoid.is_submonoid -> Submonoid.isSubmonoid is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} [_inst_1 : Monoid.{u1} M] (S : Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)), IsSubmonoid.{u1} M _inst_1 ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (Set.{u1} M) (HasLiftT.mk.{succ u1, succ u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (Set.{u1} M) (CoeTCₓ.coe.{succ u1, succ u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (Set.{u1} M) (SetLike.Set.hasCoeT.{u1, u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) M (Submonoid.setLike.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))))) S)
but is expected to have type
  forall {M : Type.{u1}} [_inst_1 : Monoid.{u1} M] (S : Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)), IsSubmonoid.{u1} M _inst_1 (SetLike.coe.{u1, u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) M (Submonoid.instSetLikeSubmonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) S)
Case conversion may be inaccurate. Consider using '#align submonoid.is_submonoid Submonoid.isSubmonoidₓ'. -/
@[to_additive]
theorem Submonoid.isSubmonoid (S : Submonoid M) : IsSubmonoid (S : Set M) :=
  ⟨S.3, fun _ _ => S.2⟩
#align submonoid.is_submonoid Submonoid.isSubmonoid
#align add_submonoid.is_add_submonoid AddSubmonoid.isAddSubmonoid


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import category_theory.eq_to_hom

/-!
# Discrete categories

We define `discrete α := α` for any type `α`, and use this type alias
to provide a `small_category` instance whose only morphisms are the identities.

There is an annoying technical difficulty that it has turned out to be inconvenient
to allow categories with morphisms living in `Prop`,
so instead of defining `X ⟶ Y` in `discrete α` as `X = Y`,
one might define it as `plift (X = Y)`.
In fact, to allow `discrete α` to be a `small_category`
(i.e. with morphisms in the same universe as the objects),
we actually define the hom type `X ⟶ Y` as `ulift (plift (X = Y))`.

`discrete.functor` promotes a function `f : I → C` (for any category `C`) to a functor
`discrete.functor f : discrete I ⥤ C`.

Similarly, `discrete.nat_trans` and `discrete.nat_iso` promote `I`-indexed families of morphisms,
or `I`-indexed families of isomorphisms to natural transformations or natural isomorphism.

We show equivalences of types are the same as (categorical) equivalences of the corresponding
discrete categories.
-/

namespace category_theory

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

/--
A type synonym for promoting any type to a category,
with the only morphisms being equalities.
-/
def discrete (α : Type u₁) := α

/--
The "discrete" category on a type, whose morphisms are equalities.

Because we do not allow morphisms in `Prop` (only in `Type`),
somewhat annoyingly we have to define `X ⟶ Y` as `ulift (plift (X = Y))`.

See https://stacks.math.columbia.edu/tag/001A
-/
instance discrete_category (α : Type u₁) : small_category (discrete α) :=
{ hom  := λ X Y, ulift (plift (X = Y)),
  id   := λ X, ulift.up (plift.up rfl),
  comp := λ X Y Z g f, by { rcases f with ⟨⟨rfl⟩⟩, exact g } }

namespace discrete

variables {α : Type u₁}

instance [inhabited α] : inhabited (discrete α) :=
by { dsimp [discrete], apply_instance }

instance [subsingleton α] : subsingleton (discrete α) :=
by { dsimp [discrete], apply_instance }

/-- Extract the equation from a morphism in a discrete category. -/

@[simp] lemma id_def (X : discrete α) : ulift.up (plift.up (eq.refl X)) = 𝟙 X := rfl

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

instance {I : Type u₁} {i j : discrete I} (f : i ⟶ j) : is_iso f :=
⟨⟨eq_to_hom (eq_of_hom f).symm, by tidy⟩⟩

/--
Any function `I → C` gives a functor `discrete I ⥤ C`.
-/
def functor {I : Type u₁} (F : I → C) : discrete I ⥤ C :=
{ obj := F,
  map := λ X Y f, begin cases f, cases f, cases f, exact 𝟙 (F X) end }

@[simp] lemma functor_obj  {I : Type u₁} (F : I → C) (i : I) :
  (discrete.functor F).obj i = F i := rfl

lemma functor_map  {I : Type u₁} (F : I → C) {i : discrete I} (f : i ⟶ i) :
  (discrete.functor F).map f = 𝟙 (F i) :=
by { cases f, cases f, cases f, refl }

/--
For functors out of a discrete category,
a natural transformation is just a collection of maps,
as the naturality squares are trivial.
-/
def nat_trans {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ⟶ G.obj i) : F ⟶ G :=
{ app := f }

@[simp] lemma nat_trans_app  {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ⟶ G.obj i) (i) : (discrete.nat_trans f).app i = f i :=
rfl

/--
For functors out of a discrete category,
a natural isomorphism is just a collection of isomorphisms,
as the naturality squares are trivial.
-/
def nat_iso {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ≅ G.obj i) : F ≅ G :=
nat_iso.of_components f (by tidy)

@[simp]
lemma nat_iso_hom_app {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ≅ G.obj i) (i : I) :
  (discrete.nat_iso f).hom.app i = (f i).hom :=
rfl

@[simp]
lemma nat_iso_inv_app {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ≅ G.obj i) (i : I) :
  (discrete.nat_iso f).inv.app i = (f i).inv :=
rfl

@[simp]
lemma nat_iso_app {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ≅ G.obj i) (i : I) :
  (discrete.nat_iso f).app i = f i :=
by tidy

/-- Every functor `F` from a discrete category is naturally isomorphic (actually, equal) to
  `discrete.functor (F.obj)`. -/
def nat_iso_functor {I : Type u₁} {F : discrete I ⥤ C} : F ≅ discrete.functor (F.obj) :=
nat_iso $ λ i, iso.refl _

/--
We can promote a type-level `equiv` to
an equivalence between the corresponding `discrete` categories.
-/
@[simps]
def equivalence {I J : Type u₁} (e : I ≃ J) : discrete I ≌ discrete J :=
{ functor := discrete.functor (e : I → J),
  inverse := discrete.functor (e.symm : J → I),
  unit_iso := discrete.nat_iso (λ i, eq_to_iso (by simp)),
  counit_iso := discrete.nat_iso (λ j, eq_to_iso (by simp)), }

/-- We can convert an equivalence of `discrete` categories to a type-level `equiv`. -/
@[simps]
def equiv_of_equivalence {α β : Type u₁} (h : discrete α ≌ discrete β) : α ≃ β :=
{ to_fun := h.functor.obj,
  inv_fun := h.inverse.obj,
  left_inv := λ a, eq_of_hom (h.unit_iso.app a).2,
  right_inv := λ a, eq_of_hom (h.counit_iso.app a).1 }

end discrete

namespace discrete
variables {J : Type v₁}

open opposite

/-- A discrete category is equivalent to its opposite category. -/
protected def opposite (α : Type u₁) : (discrete α)ᵒᵖ ≌ discrete α :=
let F : discrete α ⥤ (discrete α)ᵒᵖ := discrete.functor (λ x, op x) in
begin
  refine equivalence.mk (functor.left_op F) F _ (discrete.nat_iso $ λ X, by simp [F]),
  refine nat_iso.of_components (λ X, by simp [F]) _,
  tidy
end

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

@[simp] lemma functor_map_id
  (F : discrete J ⥤ C) {j : discrete J} (f : j ⟶ j) : F.map f = 𝟙 (F.obj j) :=
begin
  have h : f = 𝟙 j, { cases f, cases f, ext, },
  rw h,
  simp,
end

end discrete

end category_theory


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import data.rbmap.basic
import data.rbtree.main

universes u v

namespace rbmap
variables {α : Type u} {β : Type v} {lt : α → α → Prop}

/- Auxiliary instances -/
private def rbmap_lt_is_swo {α : Type u} {β : Type v} {lt : α → α → Prop}
  [is_strict_weak_order α lt] : is_strict_weak_order (α × β) (rbmap_lt lt) :=
{ irrefl       := λ _, irrefl_of lt _,
  trans        := λ _ _ _ h₁ h₂, trans_of lt h₁ h₂,
  incomp_trans := λ _ _ _ h₁ h₂, incomp_trans_of lt h₁ h₂ }

private def rbmap_lt_dec {α : Type u} {β : Type v} {lt : α → α → Prop} [h : decidable_rel lt] :
  decidable_rel (@rbmap_lt α β lt) :=
λ a b, h a.1 b.1

local attribute [instance] rbmap_lt_is_swo rbmap_lt_dec

/- Helper lemmas for reusing rbtree results. -/

private lemma to_rbtree_mem {k : α} {m : rbmap α β lt} : k ∈ m → ∃ v : β, rbtree.mem (k, v) m :=
begin
  cases m with n p; cases n; intros h,
  { exact false.elim h },
  all_goals { existsi n_val.2, exact h }
end

private lemma eqv_entries_of_eqv_keys {k₁ k₂ : α} (v₁ v₂ : β) :
  k₁ ≈[lt] k₂ → (k₁, v₁) ≈[rbmap_lt lt] (k₂, v₂) :=
id

private lemma eqv_keys_of_eqv_entries {k₁ k₂ : α} {v₁ v₂ : β} :
  (k₁, v₁) ≈[rbmap_lt lt] (k₂, v₂) → k₁ ≈[lt] k₂ :=
id

private lemma eqv_entries [is_irrefl α lt] (k : α) (v₁ v₂ : β) : (k, v₁) ≈[rbmap_lt lt] (k, v₂) :=
and.intro (irrefl_of lt k) (irrefl_of lt k)

private lemma to_rbmap_mem [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  rbtree.mem (k, v) m → k ∈ m :=
begin
  cases m with n p; cases n; intros h,
  { exact false.elim h },
  { simp [has_mem.mem, rbmap.mem],
    exact @rbtree.mem_of_mem_of_eqv _ _ _ ⟨rbnode.red_node n_lchild n_val n_rchild, p⟩ _ _ h
      (eqv_entries _ _ _) },
  { simp [has_mem.mem, rbmap.mem],
    exact @rbtree.mem_of_mem_of_eqv _ _ _ ⟨rbnode.black_node n_lchild n_val n_rchild, p⟩ _ _ h
      (eqv_entries _ _ _) }
end

private lemma to_rbtree_mem' [is_strict_weak_order α lt] {k : α} {m : rbmap α β lt} (v : β) :
  k ∈ m → rbtree.mem (k, v) m :=
begin
  intro h,
  cases to_rbtree_mem h with v' hm,
  apply rbtree.mem_of_mem_of_eqv hm,
  apply eqv_entries
end

lemma eq_some_of_to_value_eq_some {e : option (α × β)} {v : β} :
  to_value e = some v → ∃ k, e = some (k, v) :=
begin
  cases e with val; simp [to_value, false_implies_iff],
  { cases val, simp }
end

lemma eq_none_of_to_value_eq_none {e : option (α × β)} : to_value e = none → e = none :=
by cases e; simp [to_value, false_implies_iff]

/- Lemmas -/

lemma not_mem_mk_rbmap : ∀ (k : α), k ∉ mk_rbmap α β lt :=
by simp [has_mem.mem, mk_rbmap, mk_rbtree, rbmap.mem]

lemma not_mem_of_empty {m : rbmap α β lt} (k : α) : m.empty = tt → k ∉ m :=
by cases m with n p; cases n;
  simp [has_mem.mem, mk_rbmap, mk_rbtree, rbmap.mem, rbmap.empty, rbtree.empty, false_implies_iff]

lemma mem_of_mem_of_eqv [is_strict_weak_order α lt] {m : rbmap α β lt} {k₁ k₂ : α} :
  k₁ ∈ m → k₁ ≈[lt] k₂ → k₂ ∈ m :=
begin
  intros h₁ h₂,
  have h₁ := to_rbtree_mem h₁, cases h₁ with v h₁,
  exact to_rbmap_mem (rbtree.mem_of_mem_of_eqv h₁ (eqv_entries_of_eqv_keys v v h₂))
end

section decidable

variables [decidable_rel lt]

lemma not_mem_of_find_entry_none [is_strict_weak_order α lt] {k : α} {m : rbmap α β lt} :
  m.find_entry k = none → k ∉ m :=
begin
  cases m with t p, cases t; simp [find_entry],
  { intros, simp [has_mem.mem, rbmap.mem] },
  all_goals { intro h, exact rbtree.not_mem_of_find_none h, }
end

lemma not_mem_of_find_none [is_strict_weak_order α lt] {k : α} {m : rbmap α β lt} :
  m.find k = none → k ∉ m :=
begin
  simp [find], intro h,
  have := eq_none_of_to_value_eq_none h,
  exact not_mem_of_find_entry_none this
end

lemma mem_of_find_entry_some [is_strict_weak_order α lt] {k₁ : α} {e : α × β} {m : rbmap α β lt} :
  m.find_entry k₁ = some e → k₁ ∈ m :=
begin
  cases m with t p, cases t; simp [find_entry, false_implies_iff],
  all_goals { intro h, exact rbtree.mem_of_find_some h }
end

lemma mem_of_find_some [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.find k = some v → k ∈ m :=
begin
  simp [find], intro h,
  have := eq_some_of_to_value_eq_some h,
  cases this with _ he,
  exact mem_of_find_entry_some he
end

lemma find_entry_eq_find_entry_of_eqv [is_strict_weak_order α lt] {m : rbmap α β lt} {k₁ k₂ : α} :
  k₁ ≈[lt] k₂ → m.find_entry k₁ = m.find_entry k₂ :=
begin
  intro h, cases m with t p, cases t; simp [find_entry],
  all_goals { apply rbtree.find_eq_find_of_eqv, apply eqv_entries_of_eqv_keys, assumption }
end

lemma find_eq_find_of_eqv [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) :
  k₁ ≈[lt] k₂ → m.find k₁ = m.find k₂ :=
begin intro h, simp [find], apply congr_arg, apply find_entry_eq_find_entry_of_eqv, assumption end

lemma find_entry_correct [is_strict_weak_order α lt] (k : α) (m : rbmap α β lt) :
  k ∈ m ↔ (∃ e, m.find_entry k = some e ∧ k ≈[lt] e.1) :=
begin
  apply iff.intro; cases m with t p,
  { intro h,
    have h   := to_rbtree_mem h, cases h with v h₁,
    have hex := iff.mp (rbtree.find_correct _ _) h₁, cases hex with e h₂,
    existsi e, cases t; simp [find_entry] at ⊢ h₂,
    { simp [rbtree.find, rbnode.find] at h₂, cases h₂ },
    { cases h₂ with h₂₁ h₂₂, split,
      { have := rbtree.find_eq_find_of_eqv ⟨rbnode.red_node t_lchild t_val t_rchild, p⟩
          (eqv_entries k v t_val.2),
        rw [←this], exact h₂₁ },
      { cases e, apply eqv_keys_of_eqv_entries h₂₂ } },
    { cases h₂ with h₂₁ h₂₂, split,
      { have := rbtree.find_eq_find_of_eqv ⟨rbnode.black_node t_lchild t_val t_rchild, p⟩
          (eqv_entries k v t_val.2),
        rw [←this], exact h₂₁ },
      { cases e, apply eqv_keys_of_eqv_entries h₂₂ } } },
  { intro h, cases h with e h,
    cases h with h₁ h₂, cases t; simp [find_entry] at h₁,
    { contradiction },
    all_goals { exact to_rbmap_mem (rbtree.mem_of_find_some h₁) } }
end

lemma eqv_of_find_entry_some [is_strict_weak_order α lt] {k₁ k₂ : α} {v : β} {m : rbmap α β lt} :
  m.find_entry k₁ = some (k₂, v) → k₁ ≈[lt] k₂ :=
begin
  cases m with t p, cases t; simp [find_entry, false_implies_iff],
  all_goals { intro h, exact eqv_keys_of_eqv_entries (rbtree.eqv_of_find_some h) }
end

lemma eq_of_find_entry_some [is_strict_total_order α lt] {k₁ k₂ : α} {v : β} {m : rbmap α β lt} :
  m.find_entry k₁ = some (k₂, v) → k₁ = k₂ :=
λ h, suffices k₁ ≈[lt] k₂, from eq_of_eqv_lt this,
     eqv_of_find_entry_some h

lemma find_correct [is_strict_weak_order α lt] (k : α) (m : rbmap α β lt) :
  k ∈ m ↔ ∃ v, m.find k = some v :=
begin
  apply iff.intro,
  { intro h,
    have := iff.mp (find_entry_correct k m) h,
    cases this with e h, cases h with h₁ h₂,
    existsi e.2, simp [find, h₁, to_value] },
  { intro h,
    cases h with v h,
    simp [find] at h,
    have h := eq_some_of_to_value_eq_some h,
    cases h with k' h,
    have heqv := eqv_of_find_entry_some h,
    exact iff.mpr (find_entry_correct k m) ⟨(k', v), ⟨h, heqv⟩⟩ }
end

lemma constains_correct [is_strict_weak_order α lt] (k : α) (m : rbmap α β lt) :
  k ∈ m ↔ m.contains k = tt :=
begin
  apply iff.intro,
  { intro h,
    have h := iff.mp (find_entry_correct k m) h,
    cases h with e h, cases h with h₁ h₂,
    simp [contains, h₁, option.is_some] },
  { simp [contains],
    intro h,
    generalize he : find_entry m k = e,
    cases e,
    { simp [he, option.is_some] at h, contradiction },
    { exact mem_of_find_entry_some he } }
end

lemma mem_insert_of_incomp [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  (¬ lt k₁ k₂ ∧ ¬ lt k₂ k₁) → k₁ ∈ m.insert k₂ v :=
λ h, to_rbmap_mem (rbtree.mem_insert_of_incomp m (eqv_entries_of_eqv_keys v v h))

lemma mem_insert [is_strict_weak_order α lt] (k : α) (m : rbmap α β lt) (v : β) :
  k ∈ m.insert k v :=
to_rbmap_mem (rbtree.mem_insert (k, v) m)

lemma mem_insert_of_equiv [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  k₁ ≈[lt] k₂ → k₁ ∈ m.insert k₂ v :=
mem_insert_of_incomp m v

lemma mem_insert_of_mem [is_strict_weak_order α lt] {k₁ : α} {m : rbmap α β lt} (k₂ : α) (v : β) :
  k₁ ∈ m → k₁ ∈ m.insert k₂ v :=
λ h, to_rbmap_mem (rbtree.mem_insert_of_mem (k₂, v) (to_rbtree_mem' v h))

lemma equiv_or_mem_of_mem_insert [is_strict_weak_order α lt] {k₁ k₂ : α} {v : β}
  {m : rbmap α β lt} : k₁ ∈ m.insert k₂ v → k₁ ≈[lt] k₂ ∨ k₁ ∈ m :=
λ h, or.elim (rbtree.equiv_or_mem_of_mem_insert (to_rbtree_mem' v h))
  (λ h, or.inl (eqv_keys_of_eqv_entries h))
  (λ h, or.inr (to_rbmap_mem h))

lemma incomp_or_mem_of_mem_ins [is_strict_weak_order α lt] {k₁ k₂ : α} {v : β} {m : rbmap α β lt} :
  k₁ ∈ m.insert k₂ v → (¬ lt k₁ k₂ ∧ ¬ lt k₂ k₁) ∨ k₁ ∈ m :=
equiv_or_mem_of_mem_insert

lemma eq_or_mem_of_mem_ins [is_strict_total_order α lt] {k₁ k₂ : α} {v : β} {m : rbmap α β lt} :
  k₁ ∈ m.insert k₂ v → k₁ = k₂ ∨ k₁ ∈ m :=
λ h, suffices k₁ ≈[lt] k₂ ∨ k₁ ∈ m, by simp [eqv_lt_iff_eq] at this; assumption,
  incomp_or_mem_of_mem_ins h

lemma find_entry_insert_of_eqv [is_strict_weak_order α lt] (m : rbmap α β lt) {k₁ k₂ : α} (v : β) :
  k₁ ≈[lt] k₂ → (m.insert k₁ v).find_entry k₂ = some (k₁, v) :=
begin
  intro h,
  generalize h₁ : m.insert k₁ v = m',
  cases m' with t p, cases t,
  { have := mem_insert k₁ m v, rw [h₁] at this, apply absurd this, apply not_mem_mk_rbmap },
  all_goals { simp [find_entry], rw [←h₁, insert], apply rbtree.find_insert_of_eqv,
    apply eqv_entries_of_eqv_keys _ _ h }
end

lemma find_entry_insert [is_strict_weak_order α lt] (m : rbmap α β lt) (k : α) (v : β) :
  (m.insert k v).find_entry k = some (k, v) :=
find_entry_insert_of_eqv m v (refl k)

lemma find_insert_of_eqv [is_strict_weak_order α lt] (m : rbmap α β lt) {k₁ k₂ : α} (v : β) :
  k₁ ≈[lt] k₂ → (m.insert k₁ v).find k₂ = some v :=
begin
  intro h,
  have := find_entry_insert_of_eqv m v h,
  simp [find, this, to_value]
end

lemma find_insert [is_strict_weak_order α lt] (m : rbmap α β lt) (k : α) (v : β) :
  (m.insert k v).find k = some v :=
find_insert_of_eqv m v (refl k)

lemma find_entry_insert_of_disj [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  lt k₁ k₂ ∨ lt k₂ k₁ → (m.insert k₁ v).find_entry k₂ = m.find_entry k₂ :=
begin
  intro h,
  have h' : ∀ {v₁ v₂ : β}, (rbmap_lt lt) (k₁, v₁) (k₂, v₂) ∨ (rbmap_lt lt) (k₂, v₂) (k₁, v₁) :=
    λ _ _, h,
  generalize h₁ : m = m₁,
  generalize h₂ : insert m₁ k₁ v = m₂,
  rw [←h₁] at h₂ ⊢, rw [←h₂],
  cases m₁ with t₁ p₁; cases t₁; cases m₂ with t₂ p₂; cases t₂,
  { rw [h₂, h₁] },
  iterate 2
  { rw [h₂],
    conv { to_lhs, simp [find_entry] },
    rw [←h₂, insert, rbtree.find_insert_of_disj _ h', h₁],
    refl },
  any_goals { simp [insert] at h₂,
    exact absurd h₂ (rbtree.insert_ne_mk_rbtree m (k₁, v)) },
  any_goals
  { rw [h₂, h₁], simp [find_entry], rw [←h₂, ←h₁, insert, rbtree.find_insert_of_disj _ h'],
    apply rbtree.find_eq_find_of_eqv, apply eqv_entries }
end

lemma find_entry_insert_of_not_eqv [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt)
  (v : β) : ¬ k₁ ≈[lt] k₂ → (m.insert k₁ v).find_entry k₂ = m.find_entry k₂ :=
begin
  intro hn,
  have he : lt k₁ k₂ ∨ lt k₂ k₁,
  { simp [strict_weak_order.equiv, decidable.not_and_iff_or_not, decidable.not_not_iff] at hn,
    assumption },
  apply find_entry_insert_of_disj _ _ he
end

lemma find_entry_insert_of_ne [is_strict_total_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  k₁ ≠ k₂ → (m.insert k₁ v).find_entry k₂ = m.find_entry k₂ :=
begin
  intro h,
  have : ¬ k₁ ≈[lt] k₂ := λ h', h (eq_of_eqv_lt h'),
  apply find_entry_insert_of_not_eqv _ _ this
end

lemma find_insert_of_disj [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  lt k₁ k₂ ∨ lt k₂ k₁ → (m.insert k₁ v).find k₂ = m.find k₂ :=
begin intro h, have := find_entry_insert_of_disj m v h, simp [find, this] end

lemma find_insert_of_not_eqv [is_strict_weak_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  ¬ k₁ ≈[lt] k₂ → (m.insert k₁ v).find k₂ = m.find k₂ :=
begin intro h, have := find_entry_insert_of_not_eqv m v h, simp [find, this] end

lemma find_insert_of_ne [is_strict_total_order α lt] {k₁ k₂ : α} (m : rbmap α β lt) (v : β) :
  k₁ ≠ k₂ → (m.insert k₁ v).find k₂ = m.find k₂ :=
begin intro h, have := find_entry_insert_of_ne m v h, simp [find, this] end

end decidable

lemma mem_of_min_eq [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.min = some (k, v) → k ∈ m :=
λ h, to_rbmap_mem (rbtree.mem_of_min_eq h)

lemma mem_of_max_eq [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.max = some (k, v) → k ∈ m :=
λ h, to_rbmap_mem (rbtree.mem_of_max_eq h)

lemma eq_leaf_of_min_eq_none {m : rbmap α β lt} :
  m.min = none → m = mk_rbmap α β lt :=
rbtree.eq_leaf_of_min_eq_none

lemma min_is_minimal [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.min = some (k, v) → ∀ {k'}, k' ∈ m → k ≈[lt] k' ∨ lt k k' :=
λ h k' hm, or.elim (rbtree.min_is_minimal h (to_rbtree_mem' v hm))
  (λ h, or.inl (eqv_keys_of_eqv_entries h))
  (λ h, or.inr h)

lemma max_is_maximal [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.max = some (k, v) → ∀ {k'}, k' ∈ m → k ≈[lt] k' ∨ lt k' k :=
λ h k' hm, or.elim (rbtree.max_is_maximal h (to_rbtree_mem' v hm))
  (λ h, or.inl (eqv_keys_of_eqv_entries h))
  (λ h, or.inr h)

lemma min_is_minimal_of_total [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.min = some (k, v) → ∀ {k'}, k' ∈ m → k = k' ∨ lt k k' :=
λ h k' hm,
  match min_is_minimal h hm with
  | or.inl h := or.inl (eq_of_eqv_lt h)
  | or.inr h := or.inr h
  end

lemma max_is_maximal_of_total [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β lt} :
  m.max = some (k, v) → ∀ {k'}, k' ∈ m → k = k' ∨ lt k' k :=
λ h k' hm,
  match max_is_maximal h hm with
  | or.inl h := or.inl (eq_of_eqv_lt h)
  | or.inr h := or.inr h
  end

end rbmap


unsafe def f (n : Nat) :=
let rec g (x : Nat) :=
if x > 0 then
  /- This example relies on the instance `coeId {α} (a : α) : CoeT α a α`,
     The type of `g` is not provided. Thus, the expected type is
     `?m x` since the elaborator assumes it may depend on `x`.
     Thus, the expected type for the addition is `?m x`.
     The type of `g (x-1)` is `?m (x-1)`. So, we have the unification
     problem
     ```
     ?m (x-1) =?= ?m x
     ```
     and it is rejected by the unifier. Thus, the elaborator inserts
     a coercion from `?m (x-1)` to `?m x` around `g (x-1)` which creates
     the pending TC problem:
     ```
     CoeT (?m (x-1)) (g (x-1)) (?m x)
     ```

     Remark: in principle, we could solve it using a heuristic: assume
     `?m` is a constant function.
     Later, when we elaborate the else branch `0`, we have that
     ```
     ?m x =?= Nat
     ```
     which is solved using `?m := (fun _ => Nat)`.
     Then, `@coeId Nat (g (x-1))` is used to synthesize
     ```
     CoeT (?m (x-1)) (g (x-1)) (?m x)
     ```
     which is
     ```
     CoeT Nat (g (x-1)) Nat
     ```
     after we apply the assignment `?m := (fun _ => Nat)`
     -/
  g (x-1) + n
else
  0;
g n

#eval f 10


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import data.fintype.order
import data.set.finite
import order.category.LinOrd
import category_theory.limits.shapes.images
import category_theory.limits.shapes.regular_mono

/-!
# Nonempty finite linear orders

This defines `NonemptyFinLinOrd`, the category of nonempty finite linear orders with monotone maps.
This is the index category for simplicial objects.
-/

universes u v

open category_theory category_theory.limits

/-- A typeclass for nonempty finite linear orders. -/
class nonempty_fin_lin_ord (α : Type*) extends fintype α, linear_order α :=
(nonempty : nonempty α . tactic.apply_instance)

attribute [instance] nonempty_fin_lin_ord.nonempty

@[priority 100]
instance nonempty_fin_lin_ord.to_bounded_order (α : Type*) [nonempty_fin_lin_ord α] :
  bounded_order α :=
fintype.to_bounded_order α

instance punit.nonempty_fin_lin_ord : nonempty_fin_lin_ord punit := { }

instance fin.nonempty_fin_lin_ord (n : ℕ) : nonempty_fin_lin_ord (fin (n+1)) := { }

instance ulift.nonempty_fin_lin_ord (α : Type u) [nonempty_fin_lin_ord α] :
  nonempty_fin_lin_ord (ulift.{v} α) :=
{ .. linear_order.lift' equiv.ulift (equiv.injective _) }

instance (α : Type*) [nonempty_fin_lin_ord α] : nonempty_fin_lin_ord αᵒᵈ :=
{ ..order_dual.fintype α }

/-- The category of nonempty finite linear orders. -/
def NonemptyFinLinOrd := bundled nonempty_fin_lin_ord

namespace NonemptyFinLinOrd

instance : bundled_hom.parent_projection @nonempty_fin_lin_ord.to_linear_order := ⟨⟩

attribute [derive [large_category, concrete_category]] NonemptyFinLinOrd

instance : has_coe_to_sort NonemptyFinLinOrd Type* := bundled.has_coe_to_sort

/-- Construct a bundled `NonemptyFinLinOrd` from the underlying type and typeclass. -/
def of (α : Type*) [nonempty_fin_lin_ord α] : NonemptyFinLinOrd := bundled.of α

@[simp] lemma coe_of (α : Type*) [nonempty_fin_lin_ord α] : ↥(of α) = α := rfl

instance : inhabited NonemptyFinLinOrd := ⟨of punit⟩

instance (α : NonemptyFinLinOrd) : nonempty_fin_lin_ord α := α.str

instance has_forget_to_LinOrd : has_forget₂ NonemptyFinLinOrd LinOrd :=
bundled_hom.forget₂ _ _

/-- Constructs an equivalence between nonempty finite linear orders from an order isomorphism
between them. -/
@[simps] def iso.mk {α β : NonemptyFinLinOrd.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply x },
  inv_hom_id' := by { ext, exact e.apply_symm_apply x } }

/-- `order_dual` as a functor. -/
@[simps] def dual : NonemptyFinLinOrd ⥤ NonemptyFinLinOrd :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, order_hom.dual }

/-- The equivalence between `FinPartOrd` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : NonemptyFinLinOrd ≌ NonemptyFinLinOrd :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

lemma mono_iff_injective {A B : NonemptyFinLinOrd.{u}} (f : A ⟶ B) :
  mono f ↔ function.injective f :=
begin
  refine ⟨_, concrete_category.mono_of_injective f⟩,
  introI,
  intros a₁ a₂ h,
  let X : NonemptyFinLinOrd.{u} := ⟨ulift (fin 1)⟩,
  let g₁ : X ⟶ A := ⟨λ x, a₁, λ x₁ x₂ h, by refl⟩,
  let g₂ : X ⟶ A := ⟨λ x, a₂, λ x₁ x₂ h, by refl⟩,
  change g₁ (ulift.up (0 : fin 1)) = g₂ (ulift.up (0 : fin 1)),
  have eq : g₁ ≫ f = g₂ ≫ f := by { ext x, exact h, },
  rw cancel_mono at eq,
  rw eq,
end

lemma epi_iff_surjective {A B : NonemptyFinLinOrd.{u}} (f : A ⟶ B) :
  epi f ↔ function.surjective f :=
begin
  split,
  { introI,
    by_contra' hf',
    rcases hf' with ⟨m, hm⟩,
    let Y : NonemptyFinLinOrd.{u} := ⟨ulift (fin 2)⟩,
    let p₁ : B ⟶ Y := ⟨λ b, if b < m then ulift.up 0 else ulift.up 1, λ x₁ x₂ h, begin
      simp only,
      split_ifs with h₁ h₂ h₂,
      any_goals { apply fin.zero_le, },
      { exfalso,
        exact h₁ (lt_of_le_of_lt h h₂), },
      { refl, },
    end⟩,
    let p₂ : B ⟶ Y := ⟨λ b, if b ≤ m then ulift.up 0 else ulift.up 1, λ x₁ x₂ h, begin
      simp only,
      split_ifs with h₁ h₂ h₂,
      any_goals { apply fin.zero_le, },
      { exfalso,
        exact h₁ (h.trans h₂), },
      { refl, },
    end⟩,
    have h : p₁ m = p₂ m,
    { congr,
      rw ← cancel_epi f,
      ext a : 2,
      simp only [comp_apply, order_hom.coe_fun_mk],
      split_ifs with h₁ h₂ h₂,
      any_goals { refl, },
      { exfalso, exact h₂ (le_of_lt h₁), },
      { exfalso, exact hm a (eq_of_le_of_not_lt h₂ h₁), }, },
    simpa only [order_hom.coe_fun_mk, lt_self_iff_false, if_false, le_refl, if_true,
      ulift.up_inj, fin.one_eq_zero_iff, nat.succ_succ_ne_one] using h, },
  { intro h,
    exact concrete_category.epi_of_surjective f h, },
end

instance : split_epi_category NonemptyFinLinOrd.{u} :=
⟨λ X Y f hf, begin
  have H : ∀ (y : Y), nonempty (f⁻¹' { y }),
  { rw epi_iff_surjective at hf,
    intro y,
    exact nonempty.intro ⟨(hf y).some, (hf y).some_spec⟩, },
  let φ : Y → X := λ y, (H y).some.1,
  have hφ : ∀ (y : Y), f (φ y) = y := λ y, (H y).some.2,
  refine is_split_epi.mk' ⟨⟨φ, _⟩, _⟩, swap,
  { ext b,
    apply hφ, },
  { intros a b,
    contrapose,
    intro h,
    simp only [not_le] at h ⊢,
    suffices : b ≤ a,
    { apply lt_of_le_of_ne this,
      intro h',
      exfalso,
      simpa only [h', lt_self_iff_false] using h, },
    simpa only [hφ] using f.monotone (le_of_lt h), },
end⟩

instance : has_strong_epi_mono_factorisations NonemptyFinLinOrd.{u} :=
⟨λ X Y f, begin
  let I : NonemptyFinLinOrd.{u} := ⟨set.image (coe_fn f) ⊤, ⟨⟩⟩,
  let e : X ⟶ I := ⟨λ x, ⟨f x, ⟨x, by tidy⟩⟩, λ x₁ x₂ h, f.monotone h⟩,
  let m : I ⟶ Y := ⟨λ y, y, by tidy⟩,
  haveI : epi e := by { rw epi_iff_surjective, tidy, },
  haveI : strong_epi e := strong_epi_of_epi e,
  haveI : mono m := concrete_category.mono_of_injective _ (by tidy),
  exact nonempty.intro
  { I := I,
    m := m,
    e := e, },
end⟩

end NonemptyFinLinOrd

lemma NonemptyFinLinOrd_dual_comp_forget_to_LinOrd :
  NonemptyFinLinOrd.dual ⋙ forget₂ NonemptyFinLinOrd LinOrd =
    forget₂ NonemptyFinLinOrd LinOrd ⋙ LinOrd.dual := rfl


macro "ext_tactic" t:tactic "=>" newT:tactic : command => `(macro_rules | `($t) => `($newT))

syntax "trivial'" : tactic

ext_tactic trivial' => apply Eq.refl

theorem tst1 (x : Nat) : x = x :=
by trivial'

-- theorem tst2 (x y : Nat) (h : x = y) : x = y :=
-- by trivial' -- fail as expected

ext_tactic trivial' => assumption

theorem tst1b (x : Nat) : x = x :=
by trivial' -- still works

theorem tst2 (x y : Nat) (h : x = y) : x = y :=
by trivial' -- works too