import morphisms.finite
import dimension_theory.finite_algebra
import algebraic_geometry.properties
import algebraic_geometry.coproduct

open category_theory opposite topological_space

namespace algebraic_geometry

open_locale topological_space

universe u

variables {X Y : Scheme.{u}} (f : X ⟶ Y) (x : X.carrier)

lemma topological_space.opens.is_basis.Sup_eq_top {α : Type*} [topological_space α]
  {s : set (topological_space.opens α)} (hs : topological_space.opens.is_basis s) : Sup s = ⊤ :=
begin
  obtain ⟨s', hs₁, hs₂⟩ := topological_space.opens.is_basis_iff_cover.mp hs ⊤,
  rw [eq_top_iff, hs₂], exact Sup_le_Sup hs₁
end

local notation `𝖲𝗉𝖾𝖼` K := Scheme.Spec.obj (op $ CommRing.of $ K)

noncomputable
instance Scheme.stalk_algebra (x : X.carrier) :
  algebra (Scheme.Γ.obj (op X)) (X.stalk x) :=
(X.presheaf.germ ⟨x, show x ∈ (⊤ : topological_space.opens X.carrier), from trivial⟩).to_algebra

instance is_localization_stalk_of_is_affine [is_affine X] (x : X.carrier) :
  @is_localization.at_prime (Scheme.Γ.obj (op X)) _ (X.stalk x) _ _
    (X.iso_Spec.hom.val.base x).as_ideal _ :=
begin
  delta is_localization.at_prime,
  convert (top_is_affine_open X).is_localization_stalk ⟨x, trivial⟩,
  delta is_affine_open.prime_ideal_of,
  convert_to (X.of_restrict
    (topological_space.opens.open_embedding ⊤) ≫ X.iso_Spec.hom).1.base ⟨x, trivial⟩ =
    (_ ≫ Scheme.Spec.map _).1.base _,
  congr' 3,
  dsimp only [Scheme.iso_Spec, as_iso_hom],
  rw [← adjunction.unit_naturality, functor.right_op_map,
    Scheme.Γ_map_op, Scheme.of_restrict_val_c_app],
  congr' 5,
end

noncomputable
def stalk_map_iso_Γ_map_localization_of_field
  {K : Type*} [field K] [is_affine X] (f : X ⟶ 𝖲𝗉𝖾𝖼 K) (x : X.carrier) :
  arrow.mk (PresheafedSpace.stalk_map f.val x) ≅
    arrow.mk (to_Spec_Γ (CommRing.of K) ≫ Scheme.Γ.map f.op ≫
    CommRing.of_hom (algebra_map (Scheme.Γ.obj (op X))
      (@localization.at_prime
        (Scheme.Γ.obj (op X)) _ (X.iso_Spec.hom.val.base x).as_ideal _))) :=
begin
  symmetry,
  refine arrow.iso_mk' _ _ (as_iso _) _ _,
  { exact structure_sheaf.to_stalk K _ },
  { rw CommRing.is_iso_iff_bijective,
    refine (@@is_localization.at_units _ _ _ _ _ _
      (structure_sheaf.is_localization.to_stalk K _) _).bijective,
    rintro ⟨a, ha⟩, rw [subtype.coe_mk, is_unit_iff_ne_zero],
    rintro rfl, exact ha (f.1.base x).1.zero_mem },
  { exact { ..(@is_localization.alg_equiv (Scheme.Γ.obj (op X)) _
      (X.iso_Spec.hom.val.base x).as_ideal.prime_compl _ _
      localization.algebra localization.is_localization
      _ _ (Scheme.stalk_algebra x) _).to_ring_equiv.to_CommRing_iso } },
  { simp only [as_iso_hom, structure_sheaf.to_stalk, category.assoc],
    erw PresheafedSpace.stalk_map_germ',
    congr' 2,
    convert_to _ = (is_localization.alg_equiv _ _ _).to_alg_hom.to_ring_hom.comp (algebra_map _ _),
    rw [alg_hom.to_ring_hom_eq_coe, alg_hom.comp_algebra_map],
    refl }
end

noncomputable
def residue_field_map_iso_Γ_map_localization_of_field
  {K : Type*} [field K] [is_affine X] (f : X ⟶ 𝖲𝗉𝖾𝖼 K) (x : X.carrier) :
  arrow.mk (f.map_residue_field x) ≅
    arrow.mk (to_Spec_Γ (CommRing.of K) ≫ Scheme.Γ.map f.op ≫
    CommRing.of_hom (algebra_map (Scheme.Γ.obj (op X))
      (@ideal.residue_field
        (Scheme.Γ.obj (op X)) _ (X.iso_Spec.hom.val.base x).as_ideal _))) :=
begin
  symmetry,
  refine arrow.iso_mk' _ _ (as_iso _) _ _,
  { exact structure_sheaf.to_stalk K (f.1.base x) ≫ (𝖲𝗉𝖾𝖼 K).to_residue_field _ },
  { rw CommRing.is_iso_iff_bijective,
    refine ⟨ring_hom.injective _, _⟩,
    refine ideal.quotient.mk_surjective.comp (@@is_localization.at_units _ _ _ _ _ _
      (structure_sheaf.is_localization.to_stalk K _) _).surjective,
    rintro ⟨a, ha⟩, rw [subtype.coe_mk, is_unit_iff_ne_zero],
    rintro rfl, exact ha (f.1.base x).1.zero_mem },
  { refine { ..(local_ring.residue_field.map_equiv _).to_CommRing_iso },
    exact (@is_localization.alg_equiv (Scheme.Γ.obj (op X)) _
      (X.iso_Spec.hom.val.base x).as_ideal.prime_compl _ _
      localization.algebra localization.is_localization
      _ _ (Scheme.stalk_algebra x) _).to_ring_equiv },
  { simp only [as_iso_hom, structure_sheaf.to_stalk, category.assoc,
      Scheme.to_residue_field_map_residue_field, ring_equiv.to_CommRing_iso_hom],
    erw PresheafedSpace.stalk_map_germ'_assoc,
    congr' 2,
    have : is_scalar_tower (Scheme.Γ.obj (op X)) (@localization.at_prime
        (Scheme.Γ.obj (op X)) _ (X.iso_Spec.hom.val.base x).as_ideal _) (@ideal.residue_field
        (Scheme.Γ.obj (op X)) _ (X.iso_Spec.hom.val.base x).as_ideal _) :=
      ideal.residue_field.is_scalar_tower _,
    rw [@@is_scalar_tower.algebra_map_eq _ _ _ _ _ _ _ _ _ this],
    ext x,
    simp only [category_theory.comp_apply, CommRing.of_hom_apply, function.comp_app,
      alg_equiv.to_ring_equiv_eq_coe, ring_hom.coe_comp, ring_equiv.to_ring_hom_eq_coe,
      ring_equiv.coe_to_ring_hom, local_ring.residue_field.map_equiv_apply,
      local_ring.residue_field.map],
    erw ideal.quotient.algebra_map_eq,
    rw ideal.quotient.lift_mk,
    simp only [ring_equiv.refl_apply, is_localization.alg_equiv_apply, ring_equiv.to_fun_eq_coe,
      function.comp_app, ring_hom.coe_comp, alg_equiv.coe_ring_equiv, ring_equiv.coe_to_ring_hom,
      is_localization.ring_equiv_of_ring_equiv_eq],
    refl }
end

lemma is_open_singleton_tfae_of_is_affine {K : Type*} [field K] [is_affine X] (f : X ⟶ 𝖲𝗉𝖾𝖼 K)
  [locally_of_finite_type f] (x : X.carrier) :
  tfae [is_open ({x} : set X.carrier),
    is_clopen ({x} : set X.carrier),
    (PresheafedSpace.stalk_map f.1 x).finite,
    is_closed ({x} : set X.carrier) ∧ ∀ y, y ⤳ x → y = x] :=
begin
  simp only [is_clopen,
    ← (Top.homeo_of_iso $ Scheme.forget_to_Top.map_iso X.iso_Spec).is_open_image,
    ← (Top.homeo_of_iso $ Scheme.forget_to_Top.map_iso X.iso_Spec).is_closed_image,
    set.image_singleton],
  rw [arrow.iso_w' (stalk_map_iso_Γ_map_localization_of_field f x).symm,
    ring_hom.finite_respects_iso.cancel_left_is_iso,
    ring_hom.finite_respects_iso.cancel_right_is_iso],
  convert prime_spectrum.is_open_singleton_tfae_of_finite_type_of_field'
    (to_Spec_Γ (CommRing.of K) ≫ Scheme.Γ.map f.op) _ (X.iso_Spec.hom.1.base x) using 6,
  { rw eq_iff_iff, split,
    { intros H y hy,
      obtain ⟨y, rfl⟩ := (show function.surjective (X.iso_Spec.hom.val.base),
        by { rw ← Top.epi_iff_surjective, apply_instance }) y,
      rw H y, { exact le_rfl },
      rwa [← (Top.homeo_of_iso $ Scheme.forget_to_Top.map_iso X.iso_Spec).inducing.specializes_iff,
        ← prime_spectrum.le_iff_specializes] },
    { intros H y hy,
      refine (hy.antisymm _).eq,
      rw [← (Top.homeo_of_iso $ Scheme.forget_to_Top.map_iso X.iso_Spec).inducing.specializes_iff,
        ← prime_spectrum.le_iff_specializes] at hy ⊢,
      exact H hy } },
  { rwa [ring_hom.finite_type_respects_iso.cancel_left_is_iso, ← locally_of_finite_type_Spec_iff,
      arrow.iso_w' (Spec_Γ_arrow_iso_of_is_affine f),
    locally_of_finite_type_respects_iso.cancel_left_is_iso,
    locally_of_finite_type_respects_iso.cancel_right_is_iso] }
end

lemma _root_.closed_embedding.stable_under_specialization_image
  {α β : Type*} [topological_space α] [topological_space β] {f : α → β} (hf : closed_embedding f)
  {s : set α} : stable_under_specialization (f '' s) ↔ stable_under_specialization s :=
⟨λ h, set.preimage_image_eq s hf.inj ▸ h.preimage hf.continuous,
  stable_under_specialization.image hf.is_closed_map.specializing_map⟩

lemma is_closed_singleton_tfae_of_is_affine {K : Type*} [field K] [is_affine X]
  (f : X ⟶ 𝖲𝗉𝖾𝖼 K)
  [locally_of_finite_type f] (x : X.carrier) :
  tfae [is_closed ({x} : set $ X.carrier),
    stable_under_specialization ({x} : set $ X.carrier),
    (f.map_residue_field x).finite] :=
begin
  rw [← (Top.homeo_of_iso $ Scheme.forget_to_Top.map_iso X.iso_Spec).is_closed_image,
    ← (Top.homeo_of_iso $ Scheme.forget_to_Top.map_iso X.iso_Spec).closed_embedding
      .stable_under_specialization_image, set.image_singleton,
    arrow.iso_w' (residue_field_map_iso_Γ_map_localization_of_field f x).symm,
    ring_hom.finite_respects_iso.cancel_left_is_iso,
    ring_hom.finite_respects_iso.cancel_right_is_iso],
  have := prime_spectrum.is_closed_singleton_tfae_of_finite_type_of_field'
    (to_Spec_Γ _ ≫ Scheme.Γ.map f.op) _ (X.iso_Spec.hom.1.base x),
  swap,
  { rwa [ring_hom.finite_type_respects_iso.cancel_left_is_iso, ← locally_of_finite_type_Spec_iff,
      arrow.iso_w' (Spec_Γ_arrow_iso_of_is_affine f),
    locally_of_finite_type_respects_iso.cancel_left_is_iso,
    locally_of_finite_type_respects_iso.cancel_right_is_iso] },
  exact (list.tfae_cons_cons.mp this).2
end

lemma is_closed_singleton_iff_finite_of_is_affine {K : Type*} [field K] [is_affine X]
  (f : X ⟶ 𝖲𝗉𝖾𝖼 K)
  [locally_of_finite_type f] (x : X.carrier) :
  is_closed ({x} : set $ X.carrier) ↔ (f.map_residue_field x).finite :=
begin
  rw [← (Top.homeo_of_iso $ Scheme.forget_to_Top.map_iso X.iso_Spec).is_closed_image,
    set.image_singleton, arrow.iso_w' (residue_field_map_iso_Γ_map_localization_of_field f x).symm,
    ring_hom.finite_respects_iso.cancel_left_is_iso,
    ring_hom.finite_respects_iso.cancel_right_is_iso],
  refine (prime_spectrum.is_closed_singleton_iff_finite' (to_Spec_Γ _ ≫ Scheme.Γ.map f.op) _
    (X.iso_Spec.hom.1.base x)).trans _,
  { rwa [ring_hom.finite_type_respects_iso.cancel_left_is_iso, ← locally_of_finite_type_Spec_iff,
      arrow.iso_w' (Spec_Γ_arrow_iso_of_is_affine f),
    locally_of_finite_type_respects_iso.cancel_left_is_iso,
    locally_of_finite_type_respects_iso.cancel_right_is_iso] },
  refl
end

lemma is_closed_singleton_tfae {K : Type*} [field K] (f : X ⟶ 𝖲𝗉𝖾𝖼 K)
  [locally_of_finite_type f] (x : X.carrier) :
  tfae [is_closed ({x} : set $ X.carrier),
    stable_under_specialization ({x} : set $ X.carrier),
    (f.map_residue_field x).finite] :=
begin
  obtain ⟨y, hy : ((X.affine_cover.map x).1.base) y = x⟩ := X.affine_cover.covers x,
  have hf := is_open_immersion.base_open (X.affine_cover.map x),
  have e : {y} = (X.affine_cover.map x).1.base ⁻¹' {x},
  { ext1, refine hf.inj.eq_iff.symm.trans _, rw hy, refl },
  have hX : is_jacobson X.carrier :=
    locally_of_finite_type.is_jacobson f (prime_spectrum.is_jacobson_of_is_jacobson _),
  have : (f.map_residue_field x).finite ↔ ((X.affine_cover.map x ≫ f).map_residue_field y).finite,
  { rw [Scheme.hom.map_residue_field_comp, ring_hom.finite_respects_iso.cancel_right_is_iso],
    conv_lhs { rw ← hy } },
  rw this,
  have H := is_closed_singleton_tfae_of_is_affine (X.affine_cover.map x ≫ f) y,
  tfae_have : 1 → 2, { exact is_closed.stable_under_specialization },
  tfae_have : 2 → 3, { rw H.out 2 1, intro h, convert h.preimage (X.affine_cover.map x).1.base.2 },
  tfae_have : 3 → 1,
  { rw H.out 2 0, intro h, apply hX.is_closed_of_is_locally_closed,
    convert h.is_locally_closed.image hf.to_inducing hf.2.is_locally_closed,
    rw [set.image_singleton, hy] },
  tfae_finish
end

lemma is_closed_singleton_iff_finite {K : Type*} [field K] (f : X ⟶ 𝖲𝗉𝖾𝖼 K)
  [locally_of_finite_type f] (x : X.carrier) :
  is_closed ({x} : set $ X.carrier) ↔ (f.map_residue_field x).finite :=
begin
  have H₁ : ∀ (x : X.carrier) (U : topological_space.opens X.carrier) (hxU : x ∈ U),
    coe ⁻¹' ({x} : set X.carrier) = ({(⟨x, hxU⟩ : U)} : set U),
  { intros x U hxU, ext y, exact @subtype.coe_inj _ _ y ⟨x, hxU⟩ },
  have H₂ : ∀ (x : X.carrier) (U : topological_space.opens X.carrier) (hxU : x ∉ U),
    coe ⁻¹' ({x} : set X.carrier) = (∅ : set U),
  { intros x U hxU, ext ⟨y, hy⟩, refine (iff_false _).mpr _, rintro (rfl : y = x), exact hxU hy },
  split,
  { intro h,
    obtain ⟨y, hy : ((X.affine_cover.map x).1.base) y = x⟩ := X.affine_cover.covers x,
    have := (is_closed_singleton_iff_finite_of_is_affine (X.affine_cover.map x ≫ f) y).mp _,
    { rw [Scheme.hom.map_residue_field_comp,
        ring_hom.finite_respects_iso.cancel_right_is_iso] at this,
      convert this; rwa eq_comm },
    { convert h.preimage (X.affine_cover.map x).1.base.2, ext z,
      refine (is_open_immersion.base_open (X.affine_cover.map x)).inj.eq_iff.symm.trans _,
      rw hy, refl } },
  { intro h,
    rw is_closed_iff_coe_preimage_of_supr_eq_top
      ((Sup_eq_supr' _).symm.trans (is_basis_affine_open X).Sup_eq_top),
    rintro ⟨U, hU⟩,
    by_cases hxU : x ∈ U,
    { rw H₁ x U hxU,
      haveI : is_affine _ := hU,
      rwa [is_closed_singleton_iff_finite_of_is_affine (X.of_restrict U.open_embedding ≫ f) ⟨x, hxU⟩,
        Scheme.hom.map_residue_field_comp, ring_hom.finite_respects_iso.cancel_right_is_iso] },
    { rw H₂ x U hxU, exact is_closed_empty } }
end

lemma is_open_singleton_tfae {K : Type*} [field K] (f : X ⟶ 𝖲𝗉𝖾𝖼 K)
  [locally_of_finite_type f] (x : X.carrier) :
  tfae [is_open ({x} : set X.carrier),
    is_clopen ({x} : set X.carrier),
    (PresheafedSpace.stalk_map f.1 x).finite,
    is_closed ({x} : set X.carrier) ∧ stable_under_generalization ({x} : set X.carrier)] :=
begin
  obtain ⟨U, hU, hxU⟩ : ∃ U ∈ X.affine_opens, x ∈ U,
  { rw [← topological_space.opens.mem_Sup, (is_basis_affine_open X).Sup_eq_top], trivial },
  haveI : is_affine _ := hU,
  have hX : is_jacobson X.carrier :=
    locally_of_finite_type.is_jacobson f (prime_spectrum.is_jacobson_of_is_jacobson _),
  have H₁ : coe ⁻¹' ({x} : set X.carrier) = ({(⟨x, hxU⟩ : U)} : set U),
  { ext y, exact @subtype.coe_inj _ _ y ⟨x, hxU⟩ },
  have H₃ : coe '' ({(⟨x, hxU⟩ : U)} : set U) = ({x} : set X.carrier) := set.image_singleton,
  tfae_have : 1 → 2,
  { intro h, exact ⟨h, hX.is_closed_of_is_locally_closed h.is_locally_closed⟩ },
  tfae_have : 2 → 1,
  { exact is_clopen.is_open },
  tfae_have : 1 ↔ 3,
  { rw [← H₃, ← U.prop.open_embedding_subtype_coe.open_iff_image_open,
      (is_open_singleton_tfae_of_is_affine
        (X.of_restrict U.open_embedding ≫ f) ⟨x, hxU⟩).out 0 2,
      Scheme.comp_val', PresheafedSpace.stalk_map.comp,
      ring_hom.finite_respects_iso.cancel_right_is_iso],
    refl },
  tfae_have : 2 → 4,
  { intro h, exact ⟨h.is_closed, h.is_open.stable_under_generalization⟩ },
  tfae_have : 4 → 1,
  { rintro ⟨h₁, h₂⟩,
    rw [← H₃, ← U.prop.open_embedding_subtype_coe.open_iff_image_open,
      (is_open_singleton_tfae_of_is_affine
        (X.of_restrict U.open_embedding ≫ f) ⟨x, hxU⟩).out 0 3, ← H₁],
    exact ⟨embedding_subtype_coe.to_inducing.is_closed_preimage _ h₁, λ y hy,
      subtype.ext $ h₂ (embedding_subtype_coe.to_inducing.specializes_iff.mpr hy) rfl⟩ },
  tfae_finish,
end

lemma discrete_of_finite_of_finite_type {K : Type*} [field K] (f : X ⟶ 𝖲𝗉𝖾𝖼 K)
  [locally_of_finite_type f] [_root_.finite X.carrier] : discrete_topology X.carrier :=
(locally_of_finite_type.is_jacobson f $ prime_spectrum.is_jacobson_of_is_jacobson _)
  .discrete_of_finite

lemma is_open_immersion.of_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  [h₁ : is_open_immersion (f ≫ g)] [h₂ : is_open_immersion g] : is_open_immersion f :=
begin
  rw is_open_immersion_iff_stalk at h₁ h₂ ⊢,
  refine ⟨open_embedding.of_comp _ h₂.1 h₁.1, λ x, _⟩,
  have := h₁.2 x,
  rw [Scheme.comp_val', PresheafedSpace.stalk_map.comp] at this,
  haveI := h₂.2 (f.1.base x),
  rw ← is_iso.inv_hom_id_assoc (PresheafedSpace.stalk_map g.1 (f.1.base x))
    (PresheafedSpace.stalk_map f.1 x),
  exactI @@is_iso.comp_is_iso _ _ this,
end

instance {X : Scheme} {U V : opens X.carrier} (e : V ⟶ U) :
  is_open_immersion (X.restrict_functor.map e).1 :=
@@is_open_immersion.of_comp _ (X.of_restrict _)
  (by { erw is_open_immersion.lift_fac, apply_instance }) _

lemma Scheme.range_restrict_functor_map (X : Scheme) {U V : opens X.carrier} (i : U ⟶ V) :
  set.range (X.restrict_functor.map i).1.val.base = (coe ⁻¹' (U : set X.carrier) : set V) :=
begin
  rw Scheme.restrict_functor_map_base,
  ext, split, { rintro ⟨x, rfl⟩, exact x.2 }, { exact λ hx, ⟨⟨x.1, hx⟩, subtype.ext rfl⟩ }
end

noncomputable
def Scheme.is_coprod_sup_of_disjoint {X : Scheme}
  {U V : opens X.carrier} (h : disjoint U V) :
  limits.is_colimit (limits.binary_cofan.mk
    (X.restrict_functor.map $ hom_of_le (le_sup_left : U ≤ U ⊔ V)).1
    (X.restrict_functor.map $ hom_of_le le_sup_right).1) :=
begin
  apply is_coprod_of_is_open_immersion_of_is_compl,
  simp only [Scheme.range_restrict_functor_map, is_compl_iff, disjoint_iff, codisjoint_iff,
    set.sup_eq_union, set.bot_eq_empty, set.top_eq_univ, set.inf_eq_inter,
    ← opens.coe_sup, ← opens.coe_inf, ← set.preimage_inter, h.eq_bot, opens.coe_bot,
    set.preimage_empty, eq_self_iff_true, true_and, set.eq_univ_iff_forall],
  rintro ⟨x, h|h⟩,
  exacts [or.inl h, or.inr h]
end

lemma is_affine_open.of_is_closed {X : Scheme} {U V : opens X.carrier}
  (hU : is_affine_open U) (hV : is_closed (V : set X.carrier)) (e : V ≤ U) : is_affine_open V :=
begin
  let f : X.restrict V.open_embedding ⟶ X.restrict U.open_embedding :=
    (X.restrict_functor.map e.hom).1,
  haveI : is_closed_immersion f,
  { refine is_closed_immersion_iff_is_immersion.mpr ⟨infer_instance, _⟩,
    rw Scheme.range_restrict_functor_map,
    exact hV.preimage continuous_subtype_coe },
  exact @@is_affine_of_affine f _ hU,
end

lemma is_affine_open.sup_of_disjoint {X : Scheme} {U V : opens X.carrier}
  (hU : is_affine_open U) (hV : is_affine_open V) (h : disjoint U V) : is_affine_open (U ⊔ V) :=
begin
  haveI : is_affine _ := hU, haveI : is_affine _ := hV,
  have : X.restrict U.open_embedding ⨿ X.restrict V.open_embedding ≅ _ :=
    limits.colimit.iso_colimit_cocone ⟨_, Scheme.is_coprod_sup_of_disjoint h⟩,
  exact is_affine_of_iso this.inv
end

lemma _root_.ring_hom.finite.is_artinian_ring {R S : Type*} [comm_ring R] [comm_ring S]
  {f : R →+* S} (hf : f.finite) [is_artinian_ring R] : is_artinian_ring S :=
begin
  letI := f.to_algebra,
  exact @is_artinian_of_tower R S S _ _ _ _ _ _ _ (is_artinian_of_fg_of_artinian' hf.1)
end

lemma _root_.ring_hom.finite_type.is_noetherian_ring {R S : Type*} [comm_ring R] [comm_ring S]
  {f : R →+* S} (hf : f.finite_type) [is_noetherian_ring R] : is_noetherian_ring S :=
@@algebra.finite_type.is_noetherian_ring R S _ _ f.to_algebra hf _

lemma _root_.open_embedding.discrete_topology {α β : Type*} [topological_space α] [topological_space β]
  {f : α → β} (hf : open_embedding f) [h : discrete_topology β] : discrete_topology α :=
begin
  rw discrete_topology_iff_nhds at h ⊢,
  intro a, apply filter.map_injective hf.inj, rw [hf.map_nhds_eq, filter.map_pure, ← h],
end

lemma top_is_affine_open_iff {X : Scheme} : is_affine_open (⊤ : opens $ X.carrier) ↔ is_affine X :=
⟨λ h, @@is_affine_of_iso X.restrict_top_iso.inv _ h, @@top_is_affine_open X⟩

lemma finite_tfae_of_finite_type {K : Type*} [field K] (f : X ⟶ 𝖲𝗉𝖾𝖼 K)
  [hf : locally_of_finite_type f] [quasi_compact f] :
  tfae [_root_.finite X.carrier,
    discrete_topology X.carrier,
    is_affine X ∧ is_artinian_ring (Scheme.Γ.obj $ op X),
    finite f] :=
begin
  have : compact_space X.carrier,
  { rw ← is_compact_univ_iff,
    exact quasi_compact.is_compact_preimage f set.univ is_open_univ is_compact_univ },
  tfae_have : 1 → 2,
  { introI _, exact discrete_of_finite_of_finite_type f },
  tfae_have : 2 → 1,
  { introI _, exact finite_of_compact_of_discrete },
  tfae_have : 2 → 3,
  { introI H,
    haveI := tfae_2_to_1 H,
    haveI : is_affine X,
    { rw ← forall_open_iff_discrete at H,
      have : ∀ x, is_affine_open ⟨{x}, H _⟩,
      { intro x,
        obtain ⟨U, hU, hxU⟩ : ∃ U ∈ X.affine_opens, x ∈ U,
        { rw [← topological_space.opens.mem_Sup, (is_basis_affine_open X).Sup_eq_top], trivial },
        exact is_affine_open.of_is_closed hU ⟨H _⟩ ((@set.singleton_subset_iff _ x U).mpr hxU) },
      have : ∀ s, is_affine_open ⟨s, H _⟩,
      { intro s, apply set.finite.induction_on (set.to_finite s),
        { exact bot_is_affine_open _ },
        { intros x s hxs hs hs',
          have := is_affine_open.sup_of_disjoint hs' (this x) _,
          { convert this, simp only [subtype.coe_mk, set.union_singleton] },
          { rw disjoint_iff, ext1, simpa only [opens.coe_inf, subtype.coe_mk, opens.coe_bot,
              set.inter_singleton_eq_empty] } } },
      rw ← top_is_affine_open_iff,
      apply this },
    rw [locally_of_finite_type_respects_iso.arrow_mk_iso_iff
        (Spec_Γ_arrow_iso_of_is_affine f), locally_of_finite_type_Spec_iff,
      ← ring_hom.finite_type_respects_iso.cancel_left_is_iso (to_Spec_Γ (CommRing.of K))] at hf,
    refine ⟨‹_›, (is_artinian_ring_iff_is_noetherian_ring _).mpr ⟨hf.is_noetherian_ring,
      λ I hI, (prime_spectrum.is_closed_singleton_iff_is_maximal ⟨I, hI⟩).mp _⟩⟩,
    have := @@open_embedding.discrete_topology _ _ _
      (Top.homeo_of_iso $ Scheme.forget_to_Top.map_iso $ X.iso_Spec).symm.open_embedding H,
    rw ← forall_open_iff_discrete at this,
    exact ⟨this _⟩ },
  tfae_have : 3 → 1,
  { rintro ⟨h₁, h₂⟩,
    resetI,
    refine (Top.homeo_of_iso $ Scheme.forget_to_Top.map_iso X.iso_Spec).finite_iff.mpr _,
    exact (is_artinian_ring.is_prime_finite (Scheme.Γ.obj (op X))).to_subtype },
  tfae_have : 3 ↔ 4,
  { by_cases is_affine X, swap,
    { exact ⟨λ H, (h H.1).elim, λ H, by exactI (h $ is_affine_of_affine f).elim⟩, },
    resetI,
    rw [finite_respects_iso.arrow_mk_iso_iff (Spec_Γ_arrow_iso_of_is_affine f), finite_Spec_iff,
      ← ring_hom.finite_respects_iso.cancel_left_is_iso (to_Spec_Γ (CommRing.of K)),
      ← is_artinian_ring_iff_ring_hom_finite_of_field, and_iff_right],
    { assumption },
    { rwa [ring_hom.finite_type_respects_iso.cancel_left_is_iso, ← locally_of_finite_type_Spec_iff,
        ← locally_of_finite_type_respects_iso.arrow_mk_iso_iff
        (Spec_Γ_arrow_iso_of_is_affine f)] } },
  tfae_finish
end

lemma _root_.discrete_topology_iff_forall_is_open_singleton {α : Type*} [topological_space α] :
  discrete_topology α ↔ ∀ x : α, is_open ({x} : set α) :=
begin
  rw ← forall_open_iff_discrete,
  refine ⟨λ h x, h _, λ h s, _⟩,
  rw ← set.bUnion_of_singleton s,
  exact is_open_bUnion (λ _ _, h _)
end

@[priority 100]
instance is_affine.compact_space [is_affine X] : compact_space X.carrier :=
by { rw ← is_compact_univ_iff, exact (top_is_affine_open X).is_compact }

lemma discrete_topology_pullback_carrier_of_finite_type {K L : Type*}
  [field K] [field L] (f : X ⟶ 𝖲𝗉𝖾𝖼 K) (g : K →+* L)
  [hf : locally_of_finite_type f] [hX : discrete_topology X.carrier] :
  discrete_topology (limits.pullback f (Scheme.Spec.map (CommRing.of_hom g).op)).carrier :=
begin
  rw [discrete_topology_iff_forall_is_open_singleton],
  intro x,
  let 𝒰 : (limits.pullback f (Scheme.Spec.map (CommRing.of_hom g).op)).open_cover :=
    Scheme.pullback.open_cover_of_left X.affine_cover f _,
  obtain ⟨y, hy⟩ := 𝒰.covers x,
  suffices : discrete_topology (𝒰.obj $ 𝒰.f x).carrier,
  { rw [← hy, ← set.image_singleton,
      ← (is_open_immersion.base_open (𝒰.map $ 𝒰.f x)).open_iff_image_open],
    exact forall_open_iff_discrete.mpr this _ },
  haveI : quasi_compact (𝒰.map (𝒰.f x) ≫ limits.pullback.snd),
  { rw quasi_compact_over_affine_iff,
    apply_with is_affine.compact_space { instances := ff },
    apply Scheme.pullback.category_theory.limits.pullback.algebraic_geometry.is_affine },
  rw (finite_tfae_of_finite_type (𝒰.map (𝒰.f x) ≫ limits.pullback.snd)).out 1 3,
  simp only [𝒰, Scheme.pullback.open_cover_of_left_map, limits.pullback.lift_snd,
    category.comp_id],
  apply_with category_theory.limits.pullback.snd.finite { instances := ff },
  rw (finite_tfae_of_finite_type (X.affine_cover.map (𝒰.f x) ≫ f)).out 3 1,
  exact @@open_embedding.discrete_topology _ _ _
     (is_open_immersion.base_open $ X.affine_cover.map (𝒰.f x)) hX,
end

end algebraic_geometry


/-
Copyright (c) 2022 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jesse Vogel, Jannis Limperg
-/

-- Thanks to Jesse Vogel for this test case. It demonstrates the handling of
-- 'dropped' mvars. A rapp drops an mvar if the mvar appears in the parent goal
-- of the rapp, but not in any of its subgoals. In this case, we add an
-- additional regular goal for the mvar.

import Aesop

set_option aesop.check.all true

axiom Ring : Type

axiom RingHom (R S : Ring) : Type

@[aesop 99%]
axiom RingId (R : Ring) : RingHom R R

@[aesop 99%]
axiom ZZ : Ring

example : ∃ (R : Ring) (_ : RingHom R R), True := by
  aesop


structure Bar (α : Type) where
  a : α
  x : Nat → α

structure Baz (α : Type) where
  a : α → α
  β : Type
  b : α → β

set_option structureDiamondWarning false

structure Foo1 (α : Type) extends Bar (α → α), Baz α

#check @Foo1.mk

def f1 (x : Nat) : Foo1 Nat :=
  { a := id
    x := (. + .)
    b := fun _ => "" }

structure Boo1 (α : Type) extends Baz α where
  x1 : α

structure Boo2 (α : Type) extends Boo1 α where
  x2 : α

structure Foo2 (α : Type) extends Bar (α → α), Boo2 α

#check @Foo2.mk

def f2 (v : Nat) : Foo2 Nat :=
  { a  := id
    x  := (. + .)
    b  := fun _ => ""
    x1 := 1
    x2 := v }

theorem ex2 (v : Nat) : (f2 v |>.x2) = v :=
  rfl

#print Foo2.toBar
#print Foo2.toBoo2


import category_theory.sites.sheaf

open category_theory opposite

universes w v u v' u'

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

namespace category_theory.presieve

lemma mem_of_arrows_iff {ι} {B Y} (X : ι → C) (f : Π i, X i ⟶ B) (g : Y ⟶ B) :
  of_arrows X f g ↔ ∃ (i : ι) (hi : Y = X i), g = eq_to_hom hi ≫ f i :=
begin
  split,
  { rintros ⟨i⟩,
    use [i, rfl],
    simp },
  { rintros ⟨i,rfl,rfl⟩,
    simp [of_arrows.mk i] }
end

noncomputable theory

def index_of_arrows {ι} {B Y} {X : ι → C} {f : Π i, X i ⟶ B} {g : Y ⟶ B}
  (h : of_arrows X f g) : ι :=
((mem_of_arrows_iff X f g).mp h).some

lemma eq_obj_of_arrows {ι} {B Y} {X : ι → C} {f : Π i, X i ⟶ B} {g : Y ⟶ B}
  (h : of_arrows X f g) : Y = X (index_of_arrows h) :=
((mem_of_arrows_iff X f g).mp h).some_spec.some

@[simp]
lemma eq_hom_of_arrows {ι} {B Y} {X : ι → C} {f : Π i, X i ⟶ B} {g : Y ⟶ B}
  (h : of_arrows X f g) : eq_to_hom (eq_obj_of_arrows h) ≫ f _ = g :=
((mem_of_arrows_iff X f g).mp h).some_spec.some_spec.symm

def mk_family_of_elements_of_arrows {ι} {B} (X : ι → C) (f : Π i, X i ⟶ B)
  (F : Cᵒᵖ ⥤ Type w) (x : Π i, F.obj (op (X i))) :
  (of_arrows X f).family_of_elements F := λ Y f hf,
F.map (eq_to_hom $ eq_obj_of_arrows hf).op (x $ index_of_arrows hf)

lemma mk_family_of_elements_of_arrows_compatible
  {ι} {B} (X : ι → C) (f : Π i, X i ⟶ B)
  (F : Cᵒᵖ ⥤ Type w) (x : Π i, F.obj (op (X i)))
  (hx : ∀ (i j : ι) Z (g₁ : Z ⟶ X i) (g₂ : Z ⟶ X j),
    g₁ ≫ f _ = g₂ ≫ f _ → F.map g₁.op (x _) = F.map g₂.op (x _)) :
  (mk_family_of_elements_of_arrows X f F x).compatible :=
begin
  intros X Y Z g₁ g₂ f₁ f₂ h₁ h₂ h,
  dsimp [mk_family_of_elements_of_arrows],
  specialize hx (index_of_arrows h₁) (index_of_arrows h₂) Z
    (g₁ ≫ eq_to_hom (eq_obj_of_arrows h₁))
    (g₂ ≫ eq_to_hom (eq_obj_of_arrows h₂)) (by simpa),
  convert hx using 1; simp,
end

lemma mk_family_of_elements_of_arrows_eval
  {ι} {B} (X : ι → C) (f : Π i, X i ⟶ B)
  (F : Cᵒᵖ ⥤ Type w) (x : Π i, F.obj (op (X i)))
  (hx : ∀ (i j : ι) Z (g₁ : Z ⟶ X i) (g₂ : Z ⟶ X j),
    g₁ ≫ f _ = g₂ ≫ f _ → F.map g₁.op (x _) = F.map g₂.op (x _)) (i : ι) :
  (mk_family_of_elements_of_arrows X f F x) (f i) (presieve.of_arrows.mk i) = x i :=
begin
  have : X i = X (index_of_arrows (presieve.of_arrows.mk i)),
  { fapply eq_obj_of_arrows },
  rotate 2, exact f,
  dsimp [mk_family_of_elements_of_arrows],
  specialize hx i (index_of_arrows (presieve.of_arrows.mk i)),
  rotate 3, exact X, exact f,
  specialize hx (X i) (𝟙 _) (eq_to_hom this) (by simp),
  simp at hx,
  simpa using hx.symm,
end

end category_theory.presieve


import SciLean.Data.Prod
import SciLean.Core.SmoothMap
import SciLean.Core.Diff

namespace SciLean

variable {X Y Z W Y₁ Y₂ Y₃} [Diff X] [Diff Y] [Diff Z] [Diff W] [Diff Y₁] [Diff Y₂] [Diff Y₃]

def is_diff [Diff X] [Diff Y] (f : X → Y) : Prop := sorry

class IsSmoothDepNT {Xs Y' : Type} [Diff Xs] [Diff Y']
  (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y'] : Prop where
  proof : is_diff (uncurryN n f)

class IsSmoothDepN {Xs Y'}  [Diff Xs] [Diff Y']
  (n : Nat) (f : X → Y) [Prod.Uncurry n (X → Y) Xs Y'] extends IsSmoothDepNT n f : Prop

abbrev IsSmoothDep (f : X → Y) : Prop
  := IsSmoothDepN 1 f

abbrev IsSmoothDepT (f : X → Y) : Prop
  := IsSmoothDepNT 1 f

--------------------------------------------------------------------------------

instance (priority := low) IsSmoothDep.remove_2_2 (f : X → Y → Z) [IsSmoothDepNT 2 f]
  : IsSmoothDepT (λ x => f x) := sorry_proof

instance (priority := low) IsSmoothDep.remove_2_1 (f : X → Y → Z) [IsSmoothDepNT 2 f] (x : X)
  : IsSmoothDepT (λ y => f x y) := sorry_proof

instance (priority := low) IsSmoothDep.remove_3_2_3 (f : X → Y → Z → W) [IsSmoothDepNT 3 f]
  : IsSmoothDepT (λ x => f x) := sorry_proof

instance (priority := low) IsSmoothDep.remove_3_1_3 (f : X → Y → Z → W) [IsSmoothDepNT 3 f] (x : X)
  : IsSmoothDepT (λ y => f x y) := sorry_proof

instance (priority := low) IsSmoothDep.remove_3_1_2 (f : X → Y → Z → W) [IsSmoothDepNT 3 f] (x : X) (y : Y)
  : IsSmoothDepT (λ z => f x y z) := sorry_proof

-- -- adding arguments

instance (priority := low) IsSmoothDep.add_extra_2_1 (f : X → Y) [IsSmoothDepT f]
  : IsSmoothDepNT 2 (λ (z : Z) x => f x) := sorry_proof

instance (priority := low) IsSmoothDep.add_extra_2_2 (f : X → Y) [IsSmoothDepT f]
  : IsSmoothDepNT 2 (λ x (z : Z) => f x) := sorry_proof

instance (priority := low) IsSmoothDep.add_extra_3_1 (f : Y → Z → W) [IsSmoothDepNT 2 f]
  : IsSmoothDepNT 3 (λ (x : X) y z => f y z) := sorry_proof

instance (priority := low) IsSmoothDep.add_extra_3_2 (f : X → Z → W) [IsSmoothDepNT 2 f]
  : IsSmoothDepNT 3 (λ x (y : Y) z => f x z) := sorry_proof

instance (priority := low) IsSmoothDep.add_extra_3_3 (f : X → Y → W) [IsSmoothDepNT 2 f]
  : IsSmoothDepNT 3 (λ x y (z : Z) => f x y) := sorry_proof

-- Core instances

instance id.arg_x.isSmoothDep
  : IsSmoothDepT λ x : X => x := sorry_proof

-- This is problematic - low priority had to be added to `remove_2_2`
example {α : Type} : IsSmoothDepNT 1 (fun (x : α → Y) => x) := inferInstance

instance const.arg_xy.isSmoothDep
  : IsSmoothDepNT 2 λ (x : X) (y : Y) => x := inferInstance

instance const.arg_x.isSmoothDep
  : IsSmoothDepT λ (x : X) (y : Y) => x := inferInstance

instance const.arg_y.isSmoothDep (x : X)
  : IsSmoothDepT λ (y : Y) => x := IsSmoothDep.remove_2_1 (λ x y => x) x

instance (priority := low) swap.arg_y.isSmoothDep {α : Type}
  (f : α → Y → Z) [∀ x, IsSmoothDepT (f x)]
  : IsSmoothDepT (λ y x => f x y) := sorry_proof

instance parm.arg_x.isSmoothDep
  (f : X → β → Z) [IsSmoothDepT f] (y : β)
  : IsSmoothDepT (λ x => f x y) := sorry_proof

instance (priority := mid-1) subst.arg_x.isSmoothDep
  (f : X → Y → Z) [IsSmoothDepNT 2 f]
  (g : X → Y) [IsSmoothDepT g] :
  IsSmoothDepT (λ x => f x (g x)) := sorry_proof

instance (priority := mid-1) subst2.arg_x.isSmoothDep
  (f : X → Y → Y₁ → Z) [IsSmoothDepNT 3 f]
  (g : X → Y → Y₁) [IsSmoothDepNT 2 g] :
  IsSmoothDepNT 2 (λ x y => f x y (g x y)) := sorry_proof

instance (priority := mid-1) subst3.arg_x.isSmoothDep
  (f : X → Y → Z → Y₁ → W) [IsSmoothDepNT 4 f]
  (g : X → Y → Z → Y₁) [IsSmoothDepNT 3 g] :
  IsSmoothDepNT 3 (λ x y z => f x y z (g x y z)) := sorry_proof

-- @[infer_tc_goals_rl]
instance comp.arg_x.isSmoothDep
  (f : Y → Z) [IsSmoothDepT f]
  (g : X → Y) [IsSmoothDepT g]
  : IsSmoothDepT (λ x => f (g x)) := by infer_instance

instance {Ws W'} [Diff Ws] [Diff W']
  (f : Z → W) [Prod.Uncurry n W Ws W'] [IsSmoothDepNT (n+1) f]
  (g : X → Y → Z) [IsSmoothDepNT 2 g]
  : IsSmoothDepNT (n+2) fun x y => f (g x y) := sorry_proof

instance {Ws W'} [Diff Ws] [Diff W']
  (f : Y₁ → Y₂→ W) [Prod.Uncurry n W Ws W'] [hf : IsSmoothDepNT (n+2) f]
  (g₁ : X → Y → Z → Y₁) [IsSmoothDepNT 3 g₁]
  (g₂ : X → Y → Z → Y₂) [IsSmoothDepNT 3 g₂]
  : IsSmoothDepNT (n+3) fun x y z => f (g₁ x y z) (g₂ x y z) := sorry_proof

instance comp2.arg_x.isSmoothDep
  (f : Y₁ → Y₂ → Z) [IsSmoothDepNT 2 f]
  (g₁ : X → Y → Y₁) [IsSmoothDepNT 2 g₁]
  (g₂ : X → Y → Y₂) [IsSmoothDepNT 2 g₂]
  : IsSmoothDepNT 2 (λ x y => f (g₁ x y) (g₂ x y)) :=
by
  infer_instance

instance comp3.arg_x.isSmoothDep
  (f : Y₁ → Y₂ → Y₃ → W) [hf : IsSmoothDepNT ((1:ℕ) + (2:ℕ)) f]
  (g₁ : X → Y → Z → Y₁) [IsSmoothDepNT 3 g₁]
  (g₂ : X → Y → Z → Y₂) [IsSmoothDepNT 3 g₂]
  (g₃ : X → Y → Z → Y₃) [IsSmoothDepNT 3 g₃]
  : IsSmoothDepNT 3 (λ x y z => f (g₁ x y z) (g₂ x y z) (g₃ x y z)) :=
by
  infer_instance

instance Prod.fst.arg_xy.isSmoothDep : IsSmoothDep (Prod.fst : X×Y → X) := sorry_proof
instance Prod.snd.arg_xy.isSmoothDep : IsSmoothDep (Prod.snd : X×Y → Y) := sorry_proof


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

Nonnegative real numbers.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.algebra.infinite_sum
import Mathlib.topology.algebra.group_with_zero
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

namespace nnreal

protected instance topological_space : topological_space nnreal :=
  infer_instance

protected instance topological_semiring : topological_semiring nnreal :=
  topological_semiring.mk

protected instance topological_space.second_countable_topology : topological_space.second_countable_topology nnreal :=
  topological_space.subtype.second_countable_topology ℝ fun (r : ℝ) => real.le 0 r

protected instance order_topology : order_topology nnreal :=
  Mathlib.order_topology_of_ord_connected

theorem continuous_of_real : continuous nnreal.of_real :=
  continuous_subtype_mk (fun (r : ℝ) => of_real._proof_1 r) (continuous.max continuous_id continuous_const)

theorem continuous_coe : continuous coe :=
  continuous_subtype_val

@[simp] theorem tendsto_coe {α : Type u_1} {f : filter α} {m : α → nnreal} {x : nnreal} : filter.tendsto (fun (a : α) => ↑(m a)) f (nhds ↑x) ↔ filter.tendsto m f (nhds x) :=
  iff.symm tendsto_subtype_rng

theorem tendsto_coe' {α : Type u_1} {f : filter α} [filter.ne_bot f] {m : α → nnreal} {x : ℝ} : filter.tendsto (fun (a : α) => ↑(m a)) f (nhds x) ↔
  ∃ (hx : 0 ≤ x), filter.tendsto m f (nhds { val := x, property := hx }) := sorry

@[simp] theorem map_coe_at_top : filter.map coe filter.at_top = filter.at_top :=
  filter.map_coe_Ici_at_top 0

theorem comap_coe_at_top : filter.comap coe filter.at_top = filter.at_top :=
  Eq.symm (filter.at_top_Ici_eq 0)

@[simp] theorem tendsto_coe_at_top {α : Type u_1} {f : filter α} {m : α → nnreal} : filter.tendsto (fun (a : α) => ↑(m a)) f filter.at_top ↔ filter.tendsto m f filter.at_top :=
  iff.symm filter.tendsto_Ici_at_top

theorem tendsto_of_real {α : Type u_1} {f : filter α} {m : α → ℝ} {x : ℝ} (h : filter.tendsto m f (nhds x)) : filter.tendsto (fun (a : α) => nnreal.of_real (m a)) f (nhds (nnreal.of_real x)) :=
  filter.tendsto.comp (continuous.tendsto continuous_of_real x) h

protected instance has_continuous_sub : has_continuous_sub nnreal :=
  has_continuous_sub.mk
    (continuous_subtype_mk (fun (p : nnreal × nnreal) => of_real._proof_1 (↑(prod.fst p) - ↑(prod.snd p)))
      (continuous.max
        (continuous.sub (continuous.comp continuous_coe continuous_fst) (continuous.comp continuous_coe continuous_snd))
        continuous_const))

protected instance has_continuous_inv' : has_continuous_inv' nnreal :=
  has_continuous_inv'.mk sorry

theorem has_sum_coe {α : Type u_1} {f : α → nnreal} {r : nnreal} : has_sum (fun (a : α) => ↑(f a)) ↑r ↔ has_sum f r := sorry

theorem has_sum_of_real_of_nonneg {α : Type u_1} {f : α → ℝ} (hf_nonneg : ∀ (n : α), 0 ≤ f n) (hf : summable f) : has_sum (fun (n : α) => nnreal.of_real (f n)) (nnreal.of_real (tsum fun (n : α) => f n)) := sorry

theorem summable_coe {α : Type u_1} {f : α → nnreal} : (summable fun (a : α) => ↑(f a)) ↔ summable f := sorry

theorem coe_tsum {α : Type u_1} {f : α → nnreal} : ↑(tsum fun (a : α) => f a) = tsum fun (a : α) => ↑(f a) := sorry

theorem tsum_mul_left {α : Type u_1} (a : nnreal) (f : α → nnreal) : (tsum fun (x : α) => a * f x) = a * tsum fun (x : α) => f x := sorry

theorem tsum_mul_right {α : Type u_1} (f : α → nnreal) (a : nnreal) : (tsum fun (x : α) => f x * a) = (tsum fun (x : α) => f x) * a := sorry

theorem summable_comp_injective {α : Type u_1} {β : Type u_2} {f : α → nnreal} (hf : summable f) {i : β → α} (hi : function.injective i) : summable (f ∘ i) :=
  iff.mp summable_coe
    ((fun (this : summable ((coe ∘ f) ∘ i)) => this) (summable.comp_injective (iff.mpr summable_coe hf) hi))

theorem summable_nat_add (f : ℕ → nnreal) (hf : summable f) (k : ℕ) : summable fun (i : ℕ) => f (i + k) :=
  summable_comp_injective hf (add_left_injective k)

theorem summable_nat_add_iff {f : ℕ → nnreal} (k : ℕ) : (summable fun (i : ℕ) => f (i + k)) ↔ summable f := sorry

theorem sum_add_tsum_nat_add {f : ℕ → nnreal} (k : ℕ) (hf : summable f) : (tsum fun (i : ℕ) => f i) = (finset.sum (finset.range k) fun (i : ℕ) => f i) + tsum fun (i : ℕ) => f (i + k) := sorry

theorem infi_real_pos_eq_infi_nnreal_pos {α : Type u_1} [complete_lattice α] {f : ℝ → α} : (infi fun (n : ℝ) => infi fun (h : 0 < n) => f n) = infi fun (n : nnreal) => infi fun (h : 0 < n) => f ↑n := sorry


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Proofs that integrating out the KL and reparametizing are sound when
applied to the naive variational encoder.
-/
import .util .prog .graph ..prove_model_ok ..kl

namespace certigrad
namespace aevb

open graph list tactic certigrad.tactic

meta def prove_transformation (e : pexpr) :=
do whnf_target,
  [tgt, idx, H_at_idx, θ] ← intro_lst [`tgt, `idx, `H_at_idx, `θ] | failed,
  forall_idxs prove_model_base
              (do H_at_idx ← get_local `H_at_idx,
                  mk_app `and.right [H_at_idx] >>= note `H_tgt_eq,
                  H_tgt_eq_type ← get_local `H_tgt_eq >>= infer_type,
                  s ← join_user_simp_lemmas true [`cgsimp],
                  (H_tgt_eq_new_type, pr) ← simplify s H_tgt_eq_type {},
                  get_local `H_tgt_eq >>= λ H_tgt_eq, replace_hyp H_tgt_eq H_tgt_eq_new_type pr,
                  get_local `H_tgt_eq >>= subst,
                  to_expr e >>= apply,
                  all_goals (cgsimp >> try prove_is_mvn_integrable >> try prove_preconditions))
              idx

#print "proving integrate_kl_sound..."
lemma integrate_kl_sound (a : arch) (ws : weights a) (x_data : T [a^.n_in, a^.n_x]) :
let g₀ : graph := graph_naive a x_data, fdict : env := mk_input_dict ws x_data g₀ in
∀ (tgt : reference) (idx : ℕ) (H_at_idx : at_idx g₀^.targets idx tgt) (θ : T tgt.2),
E (graph.to_dist (λ m, ⟦sum_costs m (integrate_kl g₀)^.costs⟧) (env.insert tgt θ fdict) (integrate_kl g₀)^.nodes) dvec.head
=
E (graph.to_dist (λ m, ⟦sum_costs m g₀^.costs⟧) (env.insert tgt θ fdict) g₀^.nodes) dvec.head :=
by prove_transformation ```(integrate_mvn_kl_correct (ID.str label.encoding_loss) [ID.str label.decoding_loss] (graph_naive a x_data)^.nodes)

#print "proving reparam_sound..."
lemma reparam_sound (a : arch) (ws : weights a) (x_data : T [a^.n_in, a^.n_x]) :
let g₁ : graph := integrate_kl (graph_naive a x_data), fdict : env := mk_input_dict ws x_data g₁ in
∀ (tgt : reference) (idx : ℕ) (H_at_idx : at_idx g₁^.targets idx tgt) (θ : T tgt.2),
E (graph.to_dist (λ m, ⟦sum_costs m (reparam g₁)^.costs⟧) (env.insert tgt θ fdict) (reparam g₁)^.nodes) dvec.head
=
E (graph.to_dist (λ m, ⟦sum_costs m g₁^.costs⟧) (env.insert tgt θ fdict) g₁^.nodes) dvec.head :=
by prove_transformation ```(reparameterize_correct [ID.str label.encoding_loss, ID.str label.decoding_loss]
                                                   (integrate_kl $ graph_naive a x_data)^.nodes _ (ID.str label.ε, [a^.nz, a^.bs]))

#print "proving aevb_transformations_sound..."

lemma aevb_transformations_sound {a : arch} (ws : weights a) (x_data : T [a^.n_in, a^.n_x]) :
let g₀ : graph := naive_aevb a x_data, g_aevb : graph := reparam (integrate_kl g₀), fdict : env := mk_input_dict ws x_data g₀ in
∀ (tgt : reference) (idx : ℕ) (H_at_idx : at_idx g₀^.targets idx tgt) (θ : T tgt.2),
E (graph.to_dist (λ m, ⟦sum_costs m g₀^.costs⟧) (env.insert tgt θ fdict) g₀^.nodes) dvec.head
=
E (graph.to_dist (λ m, ⟦sum_costs m g_aevb^.costs⟧) (env.insert tgt θ fdict) g_aevb^.nodes) dvec.head :=

begin
whnf_target,
intros tgt idx H_at_idx θ,
-- TODO(dhs): this is annoying, rw and simp should whnf the let
note H₁ := @reparam_sound a ws x_data tgt idx,
note H₂ := @integrate_kl_sound a ws x_data tgt idx,
simp only [naive_aevb_as_graph] at *,
erw [H₁, H₂],
all_goals { assumption }
end

end aevb
end certigrad


import tactic

variables (P : Type) [partial_order P]

def presheaf : Type :=
{ s : P → Prop // ∀ a b, a ≤ b → s b → s a }

instance : has_coe_to_fun (presheaf P) (λ _, P → Prop) :=
⟨subtype.val⟩

@[simp] lemma presheaf.coe_mk (s : P → Prop) (hs : ∀ a b, a ≤ b → s b → s a) :
  @coe_fn (presheaf P) _ _ (⟨s, hs⟩ : presheaf P) = s := rfl

instance : partial_order (presheaf P) :=
{ le := λ A B, ∀ x, A x → B x,
  le_trans := λ A B C hAB hBC x hAx, hBC _ (hAB _ hAx),
  le_refl := λ A x, id,
  le_antisymm := λ A B hAB hBA, subtype.val_injective (funext $ λ x, propext ⟨hAB _, hBA _⟩) }

lemma presheaf.le_def {A B : presheaf P} : A ≤ B = ∀ x, A x → B x := rfl

instance : has_Inf (presheaf P) :=
{ Inf := λ s, ⟨λ p, ∀ A : presheaf P, A ∈ s → A p,
     λ a b hab h A hAs, A.2 _ _ hab (h _ hAs)⟩ }

instance : complete_lattice (presheaf P) :=
complete_lattice_of_Inf _
  (λ s, begin
    split,
    { dsimp [Inf, lower_bounds],
      intros A hAs p h,
      apply h,
      exact hAs },
    { dsimp [Inf, upper_bounds, lower_bounds],
      intros A h p hAp B hBs,
      apply h,
      exact hBs,
      exact hAp }
  end)

lemma infi_def {ι : Sort*} (A : ι → presheaf P) :
  infi A = ⟨λ p, ∀ i, A i p, λ x y hxy h i, (A i).2 _ y hxy (h i)⟩ :=
le_antisymm
  (infi_le_iff.2 (λ B h p hBp i, h i _ hBp))
  (le_infi (λ i p h, h _))

lemma supr_def {ι : Sort*} (A : ι → presheaf P) :
  supr A = ⟨λ p, ∃ i, A i p, λ x y hxy ⟨i, hi⟩, ⟨i, (A i).2 x y hxy hi⟩⟩ :=
le_antisymm
  (supr_le_iff.2 (λ i p h, ⟨i, h⟩))
  (le_supr_iff.2 (λ B h p ⟨i, hi⟩, h i _ hi))

variable {P}

def yoneda (a : P) : presheaf P :=
⟨λ b, b ≤ a, λ b c, le_trans⟩

def yoneda_le_iff (A : presheaf P) (p : P) : yoneda p ≤ A ↔ A p :=
begin
  simp [yoneda, presheaf.le_def],
  split,
  { intro h, apply h, exact le_rfl },
  { intros h x hxp,
    apply A.2,
    apply hxp,
    exact h }
end

@[simp] lemma yoneda_mono {a b : P} : yoneda a ≤ yoneda b ↔ a ≤ b :=
begin
  rw yoneda_le_iff, refl,
end

lemma eq_supr (A : presheaf P) : A = ⨆ (p : P) (h : A p), yoneda p :=
begin
  apply le_antisymm; simp only [le_supr_iff, supr_le_iff, yoneda_le_iff],
  { intros B hB p,
    exact hB p },
  { exact λ _, id }
end

lemma supr_eq_supr {ι : Sort*} (a : ι → presheaf P) : supr a = ⨆ (p : P) (i : ι) (h : a i p), yoneda p :=
begin
  rw [eq_supr (supr a)],
  apply le_antisymm,
  { simp only [le_supr_iff, supr_le_iff, yoneda_le_iff],
    intros p h,
    simp only [supr_def, yoneda_le_iff],
    simp only [supr_def] at *,
    cases i
    dsimp [yoneda], }

end

variables {A : Type*} [complete_lattice A] (f : P → A) (hf : monotone f)

include hf

def ump : presheaf P → A :=
λ A, ⨆ (p : P) (h : A p), f p

lemma ump_supr {ι : Sort*} (a : ι → presheaf P) : ump f hf (supr a) = ⨆ i, ump f hf (a i) :=
begin
  apply le_antisymm,
  { simp only [ump, le_supr_iff, supr_le_iff],
    intros x hx y hy,
    simp only [supr_def] at *,
    dsimp at *,
    rcases hx with ⟨i, hi⟩,
    apply hy,
    apply hi },
  { simp only [ump, le_supr_iff, supr_le_iff],
    intros i p hap x h,
    apply h,
    rw [supr_def],
    dsimp,
    use i,
    use hap }
end


import GMLInit.Data.BEq
import GMLInit.Data.Fin
import GMLInit.Data.List.Basic

namespace Array

protected theorem eq : {as bs : Array α} → as.data = bs.data → as = bs
| ⟨_⟩, ⟨_⟩, rfl => rfl

@[simp] theorem data_nil {α} : #[].data = ([] : List α) := rfl

/- get -/

theorem get_fin_eq_data_get_fin {α} (as : Array α) (i : Fin as.size) : as.get i = as.data.get i := rfl

/- set -/

theorem get_set_of_eq (as : Array α) {i : Fin as.size} {j : Nat} {x : α} {hj : j < (as.set i x).size} : i.val = j → (as.set i x)[j]'hj = x := by
  intro h
  have hj' : j < as.size := as.size_set i x ▸ hj
  rw [as.get_set i j hj']
  rw [if_pos h]

theorem get_set_of_ne (as : Array α) {i : Fin as.size} {j : Nat} {x : α} {hj : j < (as.set i x).size} : i.val ≠ j → (as.set i x)[j]'hj = as[j]'(as.size_set i x ▸ hj) := by
  intro h;
  have hj' : j < as.size := as.size_set i x ▸ hj
  rw [as.get_set i j hj']
  rw [if_neg h]

/- pop -/

theorem get_pop.aux (as : Array α) {i : Nat} : i < as.pop.size → i < as.size :=
  fun h => Nat.lt_of_lt_of_le h (as.size_pop ▸ Nat.pred_le as.size)

theorem get_pop (as : Array α) (i : Nat) (hi : i < as.pop.size) :
  as.pop[i] = as[i]'(get_pop.aux as hi) := by
  rw [←as.get_eq_getElem ⟨i, get_pop.aux as hi⟩]
  rw [←as.pop.get_eq_getElem ⟨i, hi⟩]
  rw [get, get]
  unfold pop
  rw [List.get_dropLast]

/- swap -/

theorem get_swap.aux (as : Array α) (i j : Fin as.size) {k : Nat} : k < (as.swap i j).size → k < as.size :=
  fun h => as.size_swap i j ▸ h

theorem get_swap_fst (as : Array α) (i j : Fin as.size) :
  (as.swap i j)[i.val]'(by simp [i.isLt]) = as[j.val] := by
    simp only [swap]
    rw [get_set]
    split
    next heq =>
      have : j.val = i.val := by
        rw [←heq]
        apply Fin.val_eq_val_of_heq
        rw [size_set]
        elim_casts
        reflexivity
      simp [get_eq_getElem, this]
    next =>
      rw [get_set_eq, get_eq_getElem]

theorem get_swap_snd (as : Array α) (i j : Fin as.size) :
  (as.swap i j)[j.val]'(by simp [j.isLt]) = as[i.val] := by
    simp only [swap]
    rw [get_set_of_eq]
    rw [get_eq_getElem]
    apply Fin.val_eq_val_of_heq
    rw [size_set]
    elim_casts
    reflexivity

theorem get_swap_other (as : Array α) {i j : Fin as.size} (k : Nat) (hk : k < (as.swap i j).size) :
  i.val ≠ k → j.val ≠ k → (as.swap i j)[k]'(hk) = as[k]'(as.size_swap i j ▸ hk) := by
  intro hik hjk
  have hjk : ((size_set as i (get as j)).symm ▸ j).val ≠ k := by
    intro h
    cases h
    apply hjk
    apply Fin.val_eq_val_of_heq
    rw [size_set]
    elim_casts
    reflexivity
  simp only [swap]
  rw [get_set_of_ne]
  rw [get_set_of_ne as hik]
  exact hjk

theorem get_swap (as : Array α) (i j : Fin as.size) (k : Nat) (hk : k < (as.swap i j).size) :
  (as.swap i j)[k]'(hk) = if j.val = k then as[i] else if i.val = k then as[j] else as[k]'(get_swap.aux as i j hk) := by
  split
  next hkj => cases hkj; rw [get_swap_snd]; rfl
  next hkj =>
    split
    next hki => cases hki; rw [get_swap_fst]; rfl
    next hki => rw [get_swap_other as k hk hki hkj]

/- del -/

def del (as : Array α) (k : Fin as.size) : Array α :=
  have : as.size ≠ 0 := Nat.not_eq_zero_of_lt k.isLt
  let last : Fin as.size := ⟨as.size-1, Nat.pred_lt this⟩
  (as.swap k last).pop

theorem size_del (as : Array α) (k : Fin as.size) : (as.del k).size = as.size-1 := by simp [del]

theorem get_del.aux0 (as : Array α) (k : Fin as.size) : as.size ≠ 0 :=
  Nat.not_eq_zero_of_lt k.isLt

theorem get_del.aux1 (as : Array α) (k : Fin as.size) : as.size-1 < as.size :=
  Nat.pred_lt (aux0 as k)

theorem get_del.aux2 (as : Array α) (k : Fin as.size) {i : Nat} : i < (as.del k).size → i < as.size :=
  fun h => Nat.lt_of_lt_of_le (as.size_del k ▸ h : i < as.size-1) (Nat.pred_le as.size)

theorem get_del (as : Array α) (k : Fin as.size) (i : Nat) (hi : i < (as.del k).size) :
  (as.del k)[i] = if k.val = i then as[as.size-1]'(get_del.aux1 as k) else as[i]'(get_del.aux2 as k hi) := by
  have hi' : as.size - 1 ≠ i := Ne.symm <| Nat.ne_of_lt <| size_del as k ▸ hi
  simp only [del]
  rw [get_pop]
  rw [get_swap]
  rw [if_neg hi']
  rfl

section foldlM
variable {m} [Monad m] (f : β → α → m β) (b : β)

theorem foldlM_stop (as : Array α) (stop : Nat) (hstop : stop ≤ as.size) : as.foldlM f b stop stop = pure b := by
  simp only [Array.foldlM]
  rw [dif_pos hstop]
  rw [Array.foldlM.loop]
  rw [dif_neg (by irreflexivity)]

theorem foldlM_step (as : Array α) (start stop : Nat) (hstart : start < stop) (hstop : stop ≤ as.size) :
  have : start < as.size := Nat.lt_of_lt_of_le hstart hstop
  as.foldlM f b start stop = f b as[start] >>= fun b => as.foldlM f b (start+1) stop := by
  simp only [Array.foldlM]
  rw [dif_pos hstop]
  rw [Array.foldlM.loop]
  rw [dif_pos hstart]
  split
  next heq =>
    absurd heq
    apply Nat.sub_ne_zero_of_lt hstart
  next heq =>
    simp
    congr
    funext b
    rw [dif_pos hstop]
    rw [Nat.sub_succ, heq, Nat.pred_succ]

end foldlM

section foldl
variable (f : β → α → β) (b : β)

theorem foldl_stop (as : Array α) (stop : Nat) (hstop : stop ≤ as.size) : as.foldl f b stop stop = b := by
  apply foldlM_stop; assumption

theorem foldl_step (as : Array α) (start stop : Nat) (hstart : start < stop) (hstop : stop ≤ as.size) :
  have : start < as.size := Nat.lt_of_lt_of_le hstart hstop
  as.foldl f b start stop = as.foldl f (f b as[start]) (start+1) stop := by
  apply foldlM_step; assumption; assumption

variable (h : α → α → α) [Lean.IsAssociative h]

theorem foldl_assoc (as : Array α) (b c : α) (start stop : Nat) (hstart : start ≤ stop) (hstop : stop ≤ as.size) :
  as.foldl h (h b c) start stop = h b (as.foldl h c start stop) := by
  by_cases start = stop with
  | isTrue heq =>
    cases heq
    rw [foldl_stop] <;> try (exact hstop)
    rw [foldl_stop]; exact hstop
  | isFalse hne =>
    have hstart' : start < stop := Nat.lt_of_le_of_ne hstart hne
    have : start < as.size := Nat.lt_of_lt_of_le hstart' hstop
    rw [foldl_step h (h b c)] <;> try (first | exact hstop | exact hstart')
    rw [foldl_step h c] <;> try (first | exact hstop | exact hstart')
    rw [Lean.IsAssociative.assoc (op:=h)]
    rw [foldl_assoc as b (h c as[start]) (start+1) stop hstart' hstop]
termination_by foldl_assoc => stop - start

end foldl

section foldrM
variable {m} [Monad m] (f : α → β → m β) (b : β)

theorem foldrM_stop (as : Array α) (stop : Nat) (hstop : stop ≤ as.size) : as.foldrM f b stop stop = pure b := by
  simp only [Array.foldrM]
  rw [dif_pos hstop]
  rw [if_neg (by irreflexivity)]

theorem foldrM_step (as : Array α) (start stop : Nat) (hstop : stop ≤ start) (hstart : start < as.size) :
  as.foldrM f b (start+1) stop = f as[start] b >>= fun b => as.foldrM f b start stop := by
  simp only [Array.foldrM]
  rw [dif_pos (Nat.succ_le_of_lt hstart)]
  rw [if_pos (Nat.lt_succ_of_le hstop)]
  simp only [foldrM.fold]
  split
  next heq =>
    absurd (eq_of_beq heq)
    apply Nat.ne_of_gt
    apply Nat.lt_succ_of_le
    exact hstop
  next hne =>
    congr
    funext b
    rw [dif_pos (Nat.le_of_lt hstart)]
    split
    next => rfl
    next hge =>
      have : stop = start := by
        antisymmetry using LE.le
        · exact hstop
        · exact Nat.le_of_not_gt hge
      simp [this]
      unfold foldrM.fold
      rw [BEq.rfl, if_pos rfl]

end foldrM

section foldr
variable (f : α → β → β) (b : β)

theorem foldr_stop (as : Array α) (stop : Nat) (hstop : stop ≤ as.size) : as.foldr f b stop stop = b := by
  apply foldrM_stop; assumption

theorem foldr_step (as : Array α) (start stop : Nat) (hstop : stop ≤ start) (hstart : start < as.size) :
  as.foldr f b (start+1) stop = as.foldr f (f as[start] b) start stop := by
  apply foldrM_step; assumption

end foldr

section append

theorem size_append_aux {as bs : Array α} (start stop : Nat) (hstart : start ≤ stop) (hstop : stop ≤ bs.size) :
  (foldl push as bs start stop).size = as.size + (stop - start) := by
  by_cases start = stop with
  | isTrue heq =>
    rw [heq]
    rw [foldl_stop]
    rw [Nat.sub_self]
    rw [Nat.add_zero]
    exact hstop
  | isFalse hne =>
    have hstart' : start < stop := Nat.lt_of_le_of_ne hstart hne
    rw [foldl_step push as bs start stop hstart' hstop]
    rw [size_append_aux (start+1) stop hstart' hstop]
    rw [size_push]
    rw [Nat.sub_succ']
    rw [Nat.add_assoc]
    congr
    rw [Nat.add_comm]
    have : 1 ≤ stop - start := by
      rw [Nat.le_sub_iff_add_le hstart]
      rw [Nat.add_comm]
      exact hstart'
    rw [Nat.sub_add_cancel this]
termination_by size_append_aux => stop - start

theorem get_append_aux_lo {as bs : Array α} (start stop i : Nat) (hstart : start ≤ stop) (hstop : stop ≤ bs.size) (hi : i < as.size)
  (h : i < (foldl push as bs start stop).size := by simp_arith [*]) :
  (foldl push as bs start stop)[i] = as[i] := by
  simp only [autoParam] at h
  by_cases start = stop with
  | isTrue heq =>
    congr
    rw [heq]
    rw [foldl_stop]
    exact hstop
  | isFalse hne =>
    have hstart' : start < stop := Nat.lt_of_le_of_ne hstart hne
    have : start < bs.size := Nat.lt_of_lt_of_le hstart' hstop
    have : i < (foldl push (as.push bs[start]) bs (start+1) stop).size := by
      rw [←foldl_step]
      exact h
      exact hstart'
      exact hstop
    transitivity (foldl push (as.push bs[start]) bs (start+1) stop)[i]
    · congr 1
      rw [foldl_step]
      exact hstart'
      exact hstop
    · rw [get_append_aux_lo (start+1) stop i hstart' hstop]
      rw [get_push_lt]
termination_by get_append_aux_lo => stop - start

theorem get_append_aux_hi {as bs : Array α} (start stop i : Nat) (hstart : start ≤ stop) (hstop : stop ≤ bs.size) (hi : i < stop - start)
  (ha : as.size + i < (foldl push as bs start stop).size := by simp_arith [*])
  (hb : start + i < bs.size := by simp_arith [*]):
  (foldl push as bs start stop)[as.size + i] = bs[start + i] := by
  simp only [autoParam] at ha hb
  by_cases start = stop with
  | isTrue heq =>
    rw [heq, Nat.sub_self] at hi
    contradiction
  | isFalse hne =>
    have hstart' : start < stop := Nat.lt_of_le_of_ne hstart hne
    have : start < bs.size := Nat.lt_of_lt_of_le hstart' hstop
    have : as.size + i < (foldl push (as.push bs[start]) bs (start+1) stop).size := by
      rw [size_append_aux (start+1) stop (Nat.succ_le_of_lt hstart') hstop]
      rw [size_push]
      rw [Nat.add_assoc]
      apply Nat.add_lt_add_left
      rw [Nat.add_comm]
      rw [Nat.sub_succ']
      rw [Nat.sub_add_cancel]
      exact hi
      rw [Nat.le_sub_iff_add_le hstart]
      rw [Nat.add_comm]
      exact Nat.succ_le_of_lt hstart'
    transitivity (foldl push (as.push bs[start]) bs (start+1) stop)[as.size + i]
    · congr 1
      rw [foldl_step]
      exact hstart'
      exact hstop
    · match i with
      | 0 =>
        transitivity (as.push bs[start])[as.size]
        · have h : as.size < (as.push bs[start]).size := by simp; done
          exact get_append_aux_lo (start+1) stop as.size (Nat.succ_le_of_lt hstart') hstop h _
        · rw [get_push_eq]; rfl
      | i+1 =>
        have : (as.push bs[start]).size + i < (foldl push (as.push bs[start]) bs (start+1) stop).size := by
          rw [size_append_aux (start+1) stop (Nat.succ_le_of_lt hstart') hstop]
          rw [size_push]
          apply Nat.add_lt_add_left
          rw [Nat.sub_succ']
          rw [Nat.lt_sub_iff_add_lt]
          exact hi
        transitivity (foldl push (as.push bs[start]) bs (start+1) stop)[(as.push bs[start]).size + i]
        · congr 1
          rw [size_push]
          rw [Nat.add_right_comm, Nat.add_assoc]
        · have hi' : i < stop - (start+1) := by
            rw [Nat.sub_succ']
            rw [Nat.lt_sub_iff_add_lt]
            exact hi
          have : start + 1 + i < bs.size := by rw [Nat.add_assoc, Nat.add_comm 1]; exact hb
          rw [get_append_aux_hi (start+1) stop i (Nat.succ_le_of_lt hstart') hstop hi' _ _]
          congr 1
          rw [Nat.add_right_comm, Nat.add_assoc]
          assumption

theorem data_append_aux {as bs : Array α} (start stop : Nat) (hstart : start ≤ stop) (hstop : stop ≤ bs.size) :
  (foldl push as bs start stop).data = as.data ++ bs.data.extract start stop := by
  by_cases start = stop with
  | isTrue heq =>
    cases heq
    rw [foldl_stop] <;> try assumption
    rw [List.extract_stop]
    rw [List.append_nil]
  | isFalse hne =>
    have hstart' : start < stop := Nat.lt_of_le_of_ne hstart hne
    have : start < bs.size := Nat.lt_of_lt_of_le hstart' hstop
    rw [foldl_step] <;> try assumption
    rw [List.extract_step]
    rw [data_append_aux (start+1) stop] <;> try assumption
    rw [push_data]
    rw [getElem_eq_data_get]
    rw [List.append_assoc]
    rw [List.singleton_append]
termination_by data_append_aux => stop - start

theorem size_append (as bs : Array α) : (as ++ bs).size = as.size + bs.size :=
  size_append_aux 0 bs.size (Nat.zero_le _) (Nat.le_refl _)

theorem get_append_left {as bs : Array α} (i : Nat) (hi : i < as.size) :
  have : i < (as ++ bs).size := size_append as bs ▸ Nat.lt_add_right _ _ _ hi
  (as ++ bs)[i] = as[i] :=
  get_append_aux_lo 0 bs.size i (Nat.zero_le _) (Nat.le_refl _) hi _

theorem get_append_right {as bs : Array α} (i : Nat) (hi : i < bs.size) :
  have : as.size + i < (as ++ bs).size := size_append as bs ▸ Nat.add_lt_add_left hi as.size
  (as ++ bs)[as.size + i] = bs[i] := by
  simp only [HAppend.hAppend, Append.append, Array.append]
  rw [get_append_aux_hi 0 bs.size i (Nat.zero_le _) (Nat.le_refl _) hi _ _]
  congr
  rw [Nat.zero_add]
  rw [Nat.zero_add]
  exact hi

theorem data_append {as bs : Array α} : (as ++ bs).data = as.data ++ bs.data := by
  simp only [HAppend.hAppend, Append.append, Array.append]
  rw [data_append_aux 0 bs.size (Nat.zero_le _) (Nat.le_refl _)]
  rw [List.extract_all]; rfl

theorem nil_append (as : Array α) : #[] ++ as = as := by
  apply Array.eq
  repeat rw [data_append]
  rw [data_nil]
  exact List.nil_append ..

theorem append_nil (as : Array α) : as ++ #[] = as := by
  apply Array.eq
  repeat rw [data_append]
  rw [data_nil]
  exact List.append_nil ..

theorem append_assoc (as bs cs : Array α) : (as ++ bs) ++ cs = as ++ (bs ++ cs) := by
  apply Array.eq
  repeat rw [data_append]
  exact List.append_assoc ..

end append

section sum

local instance : Lean.IsAssociative (α:=Nat) (.+.) where
  assoc := Nat.add_assoc

def sum (ns : Array Nat) (start := 0) (stop := ns.size) : Nat :=
  ns.foldl (.+.) 0 start stop

theorem sum_stop (ns : Array Nat) (stop : Nat) (hstop : stop ≤ ns.size) :
  ns.sum stop stop = 0 := by
  simp only [sum]
  rw [foldl_stop]
  exact hstop

theorem sum_step (ns : Array Nat) (start stop : Nat) (hstart : start < stop) (hstop : stop ≤ ns.size) :
  have : start < ns.size := Nat.lt_of_lt_of_le hstart hstop
  ns.sum start stop = ns[start] + ns.sum (start+1) stop := by
  have : start < ns.size := Nat.lt_of_lt_of_le hstart hstop
  simp only [sum]
  rw [foldl_step] <;> try assumption
  rw [Nat.add_comm 0 ns[start]]
  rw [ns.foldl_assoc (.+.) ns[start] 0 (start+1) stop (Nat.succ_le_of_lt hstart) hstop]

end sum

section join

local instance : Lean.IsAssociative (α:=Array α) (.++.) where
  assoc := append_assoc

def join (as : Array (Array α)) (start := 0) (stop := as.size) : Array α :=
  as.foldl (.++.) #[] start stop

def join_stop (as : Array (Array α)) (stop : Nat) (hstop : stop ≤ as.size) :
  as.join stop stop = #[] := by
  simp only [join]
  rw [foldl_stop]
  exact hstop

def join_step (as : Array (Array α)) (start stop : Nat) (hstart : start < stop) (hstop : stop ≤ as.size) :
  have : start < as.size := Nat.lt_of_lt_of_le hstart hstop
  as.join start stop = as[start] ++ as.join (start+1) stop := by
  have : start < as.size := Nat.lt_of_lt_of_le hstart hstop
  simp only [join]
  rw [foldl_step] <;> try assumption
  transitivity (foldl (.++.) (as[start] ++ #[]) as (start+1) stop)
  · rw [nil_append, append_nil]
  · rw [foldl_assoc] <;> assumption

end join

section ofFun
variable {α n} (f : Fin n → α)

unsafe def ofFunUnsafe : Array α := Id.run do
  let mut res := #[]
  for i in [:n] do
    res := res.push (f ⟨i, lcProof⟩)
  return res

@[implemented_by ofFunUnsafe]
protected def ofFun : Array α where
  data := List.ofFun f

theorem ofFun_size : (Array.ofFun f).size = n := by
  unfold Array.ofFun
  rw [Array.size_mk]
  rw [List.ofFun_length]

theorem ofFun_getElem (i : Fin (Array.ofFun f).size) : (Array.ofFun f)[i] = f (Array.ofFun_size f ▸ i) := by
  unfold Array.ofFun
  rw [Array.getElem_fin_eq_data_get]
  rw [List.ofFun_get]

theorem ofFun_get (i : Fin (Array.ofFun f).size) : (Array.ofFun f).get i = f (Array.ofFun_size f ▸ i) :=
  ofFun_getElem f i

end ofFun

end Array


/-
Copyright (c) 2019 Paul-Nicolas Madelaine. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul-Nicolas Madelaine

Normalizing casts in arithmetic expressions.
-/

import tactic.basic tactic.interactive tactic.converter.interactive
import data.complex.basic data.nat.enat

namespace tactic

/-
This is a work around to the fact that in some cases
mk_instance times out instead of failing
example: has_lift_t ℤ ℕ

mk_instance' is used when we assume the type class search
should end instantly
-/
meta def mk_instance' (e : expr) : tactic expr :=
try_for 1000 (mk_instance e)

end tactic

namespace norm_cast
open tactic expr

private meta def new_name : name → name
| name.anonymous        := name.mk_string "norm_cast" name.anonymous
| (name.mk_string s n)  := name.mk_string s (new_name n)
| (name.mk_numeral i n) := name.mk_numeral i (new_name n)

/-
let ty an expression of the shape Π (x1 : t1) ... (x2 : tn), a = b
let e an expression of type ty
then flip_equation ty returns a couple (new_ty, f) such that
    new_ty = Π A1 .. An, b = a
    f e = λ (x1 : t1) ... (xn : tn), eq.symm (e x1 ... xn)
if ty is not of the correct shape, then the tactic fails
-/
private meta def flip_equation : expr → tactic (expr × (expr → expr))
| (pi n bi d b) := do
    (ty, f) ← flip_equation $ instantiate_var b (local_const n n bi d),
    return $ (
        pi n bi d $ abstract_local ty n,
        λ e, lam n bi d $ abstract_local ( f $ e (local_const n n bi d) ) n
    )
| ty := do
    `(%%a = %%b) ← return ty | failure,
    α ← infer_type a,
    symm ← to_expr ``(@eq.symm %%α %%a %%b),
    new_ty ← to_expr ``(%%b = %%a),
    return (new_ty, symm)

private meta def after_set (decl : name) (prio : ℕ) (pers : bool) : tactic unit :=
do
    (declaration.thm n l ty task_e) ← get_decl decl | failed,
    let new_n := new_name n,
    ( do
        /-
        equation lemmas have to be flipped before
        being added to the set of norm_cast lemmas
        -/
        (new_ty, f) ← flip_equation ty,
        let task_new_e := task.map f task_e,
        add_decl (declaration.thm new_n l new_ty task_new_e)
    ) <|> ( do
        add_decl (declaration.thm new_n l ty task_e)
    )

private meta def mk_cache : list name → tactic simp_lemmas :=
monad.foldl (λ s, s.add_simp ∘ new_name) simp_lemmas.mk

/--
This is an attribute for simplification rules that are going to be
used to normalize casts.

Equation lemmas are compositional lemmas of the shape
    Π ..., ↑(P a1 ... an) = P ↑a1 ... ↑an
Equivalence lemmas are of the shape
    Π ..., P ↑a ↑b ↔ P a b

Note that the goal of normalization is to move casts "upwards" in the
expression, but compositional rules are written in a "downwards"
fashion.
-/
@[user_attribute]
meta def norm_cast_attr : user_attribute simp_lemmas :=
{
    name      := `norm_cast,
    descr     := "attribute for cast normalization",
    after_set := some after_set,
    cache_cfg := {
        mk_cache     := mk_cache,
        dependencies := [],
    }
}

/--
This is an attribute given to the lemmas of the shape
Π ..., ↑↑a = ↑a or  Π ..., ↑a = a

They are used in a heuristic to infer intermediate casts.
-/
@[user_attribute]
meta def simp_cast_attr : user_attribute simp_lemmas :=
{
    name      := `simp_cast,
    descr     := "attribute for cast simplification",
    after_set := none,
    cache_cfg := {
        mk_cache     := monad.foldl simp_lemmas.add_simp simp_lemmas.mk,
        dependencies := [],
    }
}

/-
This is an auxiliary function that proves e = new_e
using only simp_cast lemmas
-/
private meta def aux_simp (e new_e : expr) : tactic expr :=
do
    s ← simp_cast_attr.get_cache,
    (e', pr) ← s.rewrite new_e,
    is_def_eq e e',
    mk_eq_symm pr

/-
This is the main heuristic used alongside the norm_cast lemmas.
An expression of the shape: op (↑(x : α) : γ) (↑(y : β) : γ)
is rewritten as:            op (↑(↑(x : α) : β) : γ) (↑(y : β) : γ)
when the simp_cast lemmas can prove that (↑(x : α) : γ) = (↑(↑(x : α) : β) : γ)
-/
private meta def heur (_ : unit) (e : expr) : tactic (unit × expr × expr) :=
match e with
| (app (expr.app op x) y) :=
do
    `(@coe %%α %%δ %%coe1 %%xx) ← return x,
    `(@coe %%β %%γ %%coe2 %%yy) ← return y,
    success_if_fail $ is_def_eq α β,
    is_def_eq δ γ,

    (do
        coe3 ← mk_app `has_lift_t [α, β] >>= mk_instance',
        new_x ← to_expr ``(@coe %%β %%δ %%coe2 (@coe %%α %%β %%coe3 %%xx)),
        let new_e := app (app op new_x) y,
        eq_x ← aux_simp x new_x,
        pr ← mk_congr_arg op eq_x,
        pr ← mk_congr_fun pr y,
        return ((), new_e, pr)
    ) <|> (do
        coe3 ← mk_app `has_lift_t [β, α] >>= mk_instance',
        new_y ← to_expr ``(@coe %%α %%δ %%coe1 (@coe %%β %%α %%coe3 %%yy)),
        let new_e := app (app op x) new_y,
        eq_y ← aux_simp y new_y,
        pr ← mk_congr_arg (app op x) eq_y,
        return ((), new_e, pr)
    )
| _ := failed
end

-- simpa is used to discharge proofs
private meta def prove : tactic unit :=
tactic.interactive.simpa none ff [] [] none

private meta def post (_ : unit) (e : expr) : tactic (unit × expr × expr) :=
do
    s ← norm_cast_attr.get_cache,
    r ← mcond (is_prop e) (return `iff) (return `eq),
    (new_e, pr) ← s.rewrite e prove r,
    pr ← match r with
    |`iff := mk_app `propext [pr]
    | _   := return pr
    end,
    return ((), new_e, pr)

/-
This is a function to pre-process numerals:
- (1 : α) is rewritten as ((1 : ℕ) : α)
- (0 : α) is rewritten as ((0 : ℕ) : α)
-/
private meta def aux_num (_ : unit) (e : expr) : tactic (unit × expr × expr) :=
match e with
| `(0 : ℕ) := failed
| `(1 : ℕ) := failed
| `(@has_zero.zero %%α %%h) := do
    coe_nat ← to_expr ``(has_lift_t ℕ %%α) >>= mk_instance',
    new_e ← to_expr ``(@coe ℕ %%α %%coe_nat 0),
    pr ← aux_simp e new_e,
    return ((), new_e, pr)
| `(@has_one.one %%α %%h) := do
    coe_nat ← to_expr ``(has_lift_t ℕ %%α) >>= mk_instance',
    new_e ← to_expr ``(@coe ℕ %%α %%coe_nat 1),
    pr ← aux_simp e new_e,
    return ((), new_e, pr)
| _ := failed
end

/-
Core function
-/
meta def derive (e : expr) : tactic (expr × expr) :=
do
    e ← instantiate_mvars e,
    let cfg : simp_config := {fail_if_unchanged := ff},

    -- step 1: pre-processing numerals
    ((), new_e, pr1) ← simplify_bottom_up () aux_num e cfg,

    -- step 2: casts are moved outwards as much as possible using norm_cast lemmas
    ((), new_e, pr2) ← simplify_bottom_up () (λ a e, post a e <|> heur a e) new_e cfg,

    -- step 3: casts are simplified using simp_cast lemmas
    s ← simp_cast_attr.get_cache,
    (new_e, pr3) ← simplify s [] new_e cfg,

    guard (¬ new_e =ₐ e),
    pr ← mk_eq_trans pr2 pr3 >>= mk_eq_trans pr1,
    return (new_e, pr)

end norm_cast

namespace tactic
open tactic expr
open norm_cast

private meta def aux_mod_cast (e : expr) : tactic expr :=
match e with
| local_const _ lc _ _ := do
    e ← get_local lc,
    replace_at derive [e] tt,
    get_local lc
| e := do
    t ← infer_type e,
    e ← assertv `this t e,
    replace_at derive [e] tt,
    get_local `this
end

meta def exact_mod_cast (e : expr) : tactic unit :=
( do
    new_e ← aux_mod_cast e,
    exact new_e
) <|> fail "exact_mod_cast failed"

meta def apply_mod_cast (e : expr) : tactic (list (name × expr)) :=
( do
    new_e ← aux_mod_cast e,
    apply new_e
) <|> fail "apply_mod_cast failed"

meta def assumption_mod_cast : tactic unit :=
do {
    let cfg : simp_config := {
        fail_if_unchanged := ff,
        canonize_instances := ff,
        canonize_proofs := ff,
        proj := ff
    },
    ctx ← local_context,
    replace_at derive ctx tt,
    assumption
} <|> fail "assumption_mod_cast failed"

end tactic

namespace tactic.interactive
open tactic interactive tactic.interactive interactive.types expr lean.parser
open norm_cast

local postfix `?`:9001 := optional

/--
Normalize casts at the given locations by moving them "upwards".
As opposed to simp, norm_cast can be used without necessarily
closing the goal.
-/
meta def norm_cast (loc : parse location) : tactic unit :=
do
    ns ← loc.get_locals,
    tt ← replace_at derive ns loc.include_goal
        | fail "norm_cast failed to simplify",
    when loc.include_goal $ try tactic.reflexivity,
    when loc.include_goal $ try tactic.triv,
    when (¬ ns.empty) $ try tactic.contradiction

/--
Rewrite with the given rule and normalize casts between steps.
-/
meta def rw_mod_cast (rs : parse rw_rules) (loc : parse location) : tactic unit :=
( do
    let cfg_norm : simp_config := {},
    let cfg_rw : rewrite_cfg := {},
    ns ← loc.get_locals,
    monad.mapm' (λ r : rw_rule, do
        save_info r.pos,
        replace_at derive ns loc.include_goal,
        rw ⟨[r], none⟩ loc {}
    ) rs.rules,
    replace_at derive ns loc.include_goal,
    skip
) <|> fail "rw_mod_cast failed"

/--
Normalize the goal and the givin expression,
then close the goal with exact.
-/
meta def exact_mod_cast (e : parse texpr) : tactic unit :=
do
    e ← i_to_expr e <|> do {
        ty ← target,
        e ← i_to_expr_strict ``(%%e : %%ty),
        pty ← pp ty, ptgt ← pp e,
        fail ("exact_mod_cast failed, expression type not directly " ++
        "inferrable. Try:\n\nexact_mod_cast ...\nshow " ++
        to_fmt pty ++ ",\nfrom " ++ ptgt : format)
    },
    tactic.exact_mod_cast e

/--
Normalize the goal and the given expression,
then apply the expression to the goal.
-/
meta def apply_mod_cast (e : parse texpr) : tactic unit :=
do
    e ← i_to_expr_for_apply e,
    concat_tags $ tactic.apply_mod_cast e

/--
Normalize the goal and every expression in the local context,
then close the goal with assumption.
-/
meta def assumption_mod_cast : tactic unit :=
tactic.assumption_mod_cast

end tactic.interactive

namespace conv.interactive
open conv tactic tactic.interactive interactive interactive.types
open norm_cast (derive)

meta def norm_cast : conv unit := replace_lhs derive

end conv.interactive

/- simp_cast lemmas -/

attribute [simp_cast] nat.cast_zero
attribute [simp_cast] int.coe_nat_zero
attribute [simp_cast] int.cast_zero
attribute [simp_cast] rat.cast_zero
attribute [simp_cast] complex.of_real_zero

attribute [simp_cast] nat.cast_one
attribute [simp_cast] int.coe_nat_one
attribute [simp_cast] int.cast_one
attribute [simp_cast] rat.cast_one
attribute [simp_cast] complex.of_real_one

attribute [simp_cast] nat.cast_id
attribute [simp_cast] int.cast_id
attribute [simp_cast] rat.cast_id

attribute [simp_cast] int.cast_coe_nat
attribute [simp_cast] int.cast_coe_nat'
attribute [simp_cast] rat.cast_coe_nat
attribute [simp_cast] rat.cast_coe_int
attribute [simp_cast] complex.of_real_int_cast
attribute [simp_cast] complex.of_real_nat_cast
attribute [simp_cast] complex.of_real_rat_cast

attribute [simp_cast] enat.coe_zero
attribute [simp_cast] enat.coe_one
attribute [simp_cast] enat.coe_get

attribute [simp_cast] rat.coe_nat_num
attribute [simp_cast] rat.coe_int_num
attribute [simp_cast] rat.coe_nat_denom

/- compositional norm_cast lemmas -/

attribute [norm_cast] nat.cast_succ
attribute [norm_cast] int.coe_nat_succ

attribute [norm_cast] nat.cast_add
attribute [norm_cast] int.coe_nat_add
attribute [norm_cast] int.cast_add
attribute [norm_cast] rat.cast_add
attribute [norm_cast] complex.of_real_add
attribute [norm_cast] enat.coe_add

attribute [norm_cast] int.cast_neg_succ_of_nat
attribute [norm_cast] int.cast_neg_of_nat
attribute [norm_cast] int.cast_neg
attribute [norm_cast] rat.cast_neg
attribute [norm_cast] complex.of_real_neg

attribute [norm_cast] nat.cast_sub
attribute [norm_cast] int.cast_sub_nat_nat
attribute [norm_cast] int.coe_nat_sub
attribute [norm_cast] int.cast_sub
attribute [norm_cast] rat.cast_sub
attribute [norm_cast] complex.of_real_sub

attribute [norm_cast] nat.cast_mul
attribute [norm_cast] int.coe_nat_mul
attribute [norm_cast] int.cast_mul
attribute [norm_cast] rat.cast_mul
attribute [norm_cast] complex.of_real_mul

attribute [norm_cast] rat.cast_inv
attribute [norm_cast] complex.of_real_inv

attribute [norm_cast] int.coe_nat_div
attribute [norm_cast] rat.cast_div
attribute [norm_cast] complex.of_real_div

attribute [norm_cast] nat.cast_min
attribute [norm_cast] int.cast_min
attribute [norm_cast] rat.cast_min

attribute [norm_cast] nat.cast_max
attribute [norm_cast] int.cast_max
attribute [norm_cast] rat.cast_max

attribute [norm_cast] int.coe_nat_abs
attribute [norm_cast] int.cast_abs
attribute [norm_cast] rat.cast_abs

attribute [norm_cast] nat.cast_pow
attribute [norm_cast] int.coe_nat_pow
attribute [norm_cast] int.cast_pow
attribute [norm_cast] rat.cast_pow
attribute [norm_cast] complex.of_real_pow
attribute [norm_cast] complex.of_real_fpow

attribute [norm_cast] nat.cast_bit0
@[norm_cast] lemma int.coe_nat_bit0 (n : ℕ) : (↑(bit0 n) : ℤ) = bit0 ↑n := by {unfold bit0, simp}
attribute [norm_cast] int.cast_bit0
attribute [norm_cast] rat.cast_bit0
attribute [norm_cast] complex.of_real_bit0

attribute [norm_cast] nat.cast_bit1
@[norm_cast] lemma int.coe_nat_bit1 (n : ℕ) : (↑(bit1 n) : ℤ) = bit1 ↑n := by {unfold bit1, unfold bit0, simp}
attribute [norm_cast] int.cast_bit1
attribute [norm_cast] rat.cast_bit1
attribute [norm_cast] complex.of_real_bit1

@[norm_cast]
lemma ite_lemma {α β : Type} [has_coe α β] {c : Prop} [decidable c] {a b : α} :
    ↑(ite c a b) = ite c (↑a : β) (↑b : β) :=
if h : c then
    by simp [h]
else
    by simp [h]

/- equivalence norm_cast lemmas -/

attribute [norm_cast] nat.cast_inj
attribute [norm_cast] int.coe_nat_inj'
attribute [norm_cast] int.cast_inj
attribute [norm_cast] rat.cast_inj
attribute [norm_cast] complex.of_real_inj

attribute [norm_cast] nat.cast_le
attribute [norm_cast] int.coe_nat_le
attribute [norm_cast] int.cast_le
attribute [norm_cast] rat.cast_le
attribute [norm_cast] enat.coe_le_coe

attribute [norm_cast] nat.cast_lt
attribute [norm_cast] int.coe_nat_lt
attribute [norm_cast] int.cast_lt
attribute [norm_cast] rat.cast_lt
attribute [norm_cast] enat.coe_lt_coe

attribute [norm_cast] int.coe_nat_dvd

/- special lemmas to unfold ≥, > and ≠ -/

@[norm_cast] lemma ge_from_le {α} [has_le α] : ∀ (x y : α), x ≥ y ↔ y ≤ x := by simp
@[norm_cast] lemma gt_from_lt {α} [has_lt α] : ∀ (x y : α), x > y ↔ y < x := by simp
@[norm_cast] lemma ne_from_not_eq {α} : ∀ (x y : α), x ≠ y ↔ ¬(x = y) := by simp


import smt2

lemma refl_should_pass (x : int) : x = x :=
by z3


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import ring_theory.subsemiring.pointwise
import group_theory.subgroup.pointwise
import ring_theory.subring.basic

/-! # Pointwise instances on `subring`s

This file provides the action `subring.pointwise_mul_action` which matches the action of
`mul_action_set`.

This actions is available in the `pointwise` locale.

## Implementation notes

This file is almost identical to `ring_theory/subsemiring/pointwise.lean`. Where possible, try to
keep them in sync.

-/

variables {M R : Type*}

namespace subring

section monoid
variables [monoid M] [ring R] [mul_semiring_action M R]

/-- The action on a subring corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale. -/
protected def pointwise_mul_action : mul_action M (subring R) :=
{ smul := λ a S, S.map (mul_semiring_action.to_ring_hom _ _ a),
  one_smul := λ S,
    (congr_arg (λ f, S.map f) (ring_hom.ext $ by exact one_smul M)).trans S.map_id,
  mul_smul := λ a₁ a₂ S,
    (congr_arg (λ f, S.map f) (ring_hom.ext $ by exact mul_smul _ _)).trans (S.map_map _ _).symm }

localized "attribute [instance] subring.pointwise_mul_action" in pointwise
open_locale pointwise

lemma pointwise_smul_def {a : M} (S : subring R) :
  a • S = S.map (mul_semiring_action.to_ring_hom _ _ a) := rfl

@[simp] lemma coe_pointwise_smul (m : M) (S : subring R) : ↑(m • S) = m • (S : set R) := rfl

@[simp] lemma pointwise_smul_to_add_subgroup (m : M) (S : subring R) :
  (m • S).to_add_subgroup = m • S.to_add_subgroup := rfl

@[simp] lemma pointwise_smul_to_subsemiring (m : M) (S : subring R) :
  (m • S).to_subsemiring = m • S.to_subsemiring := rfl

lemma smul_mem_pointwise_smul (m : M) (r : R) (S : subring R) : r ∈ S → m • r ∈ m • S :=
(set.smul_mem_smul_set : _ → _ ∈ m • (S : set R))

lemma mem_smul_pointwise_iff_exists (m : M) (r : R) (S : subring R) :
  r ∈ m • S ↔ ∃ (s : R), s ∈ S ∧ m • s = r :=
(set.mem_smul_set : r ∈ m • (S : set R) ↔ _)

instance pointwise_central_scalar [mul_semiring_action Mᵐᵒᵖ R] [is_central_scalar M R] :
  is_central_scalar M (subring R) :=
⟨λ a S, congr_arg (λ f, S.map f) $ ring_hom.ext $ by exact op_smul_eq_smul _⟩

end monoid

section group
variables [group M] [ring R] [mul_semiring_action M R]

open_locale pointwise

@[simp] lemma smul_mem_pointwise_smul_iff {a : M} {S : subring R} {x : R} :
  a • x ∈ a • S ↔ x ∈ S :=
smul_mem_smul_set_iff

lemma mem_pointwise_smul_iff_inv_smul_mem {a : M} {S : subring R} {x : R} :
  x ∈ a • S ↔ a⁻¹ • x ∈ S :=
mem_smul_set_iff_inv_smul_mem

lemma mem_inv_pointwise_smul_iff {a : M} {S : subring R} {x : R} : x ∈ a⁻¹ • S ↔ a • x ∈ S :=
mem_inv_smul_set_iff

@[simp] lemma pointwise_smul_le_pointwise_smul_iff {a : M} {S T : subring R} :
  a • S ≤ a • T ↔ S ≤ T :=
set_smul_subset_set_smul_iff

lemma pointwise_smul_subset_iff {a : M} {S T : subring R} : a • S ≤ T ↔ S ≤ a⁻¹ • T :=
set_smul_subset_iff

lemma subset_pointwise_smul_iff {a : M} {S T : subring R} : S ≤ a • T ↔ a⁻¹ • S ≤ T :=
subset_set_smul_iff

/-! TODO: add `equiv_smul` like we have for subgroup. -/

end group

section group_with_zero
variables [group_with_zero M] [ring R] [mul_semiring_action M R]

open_locale pointwise

@[simp] lemma smul_mem_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) (S : subring R)
  (x : R) : a • x ∈ a • S ↔ x ∈ S :=
smul_mem_smul_set_iff₀ ha (S : set R) x

lemma mem_pointwise_smul_iff_inv_smul_mem₀ {a : M} (ha : a ≠ 0) (S : subring R) (x : R) :
  x ∈ a • S ↔ a⁻¹ • x ∈ S :=
mem_smul_set_iff_inv_smul_mem₀ ha (S : set R) x

lemma mem_inv_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) (S : subring R) (x : R) :
  x ∈ a⁻¹ • S ↔ a • x ∈ S :=
mem_inv_smul_set_iff₀ ha (S : set R) x

@[simp] lemma pointwise_smul_le_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) {S T : subring R} :
  a • S ≤ a • T ↔ S ≤ T :=
set_smul_subset_set_smul_iff₀ ha

lemma pointwise_smul_le_iff₀ {a : M} (ha : a ≠ 0) {S T : subring R} : a • S ≤ T ↔ S ≤ a⁻¹ • T :=
set_smul_subset_iff₀ ha

lemma le_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) {S T : subring R} : S ≤ a • T ↔ a⁻¹ • S ≤ T :=
subset_set_smul_iff₀ ha

end group_with_zero

end subring