/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.basic
import ring_theory.noetherian

/-!
# Lie subalgebras

This file defines Lie subalgebras of a Lie algebra and provides basic related definitions and
results.

## Main definitions

  * `lie_subalgebra`
  * `lie_subalgebra.incl`
  * `lie_subalgebra.map`
  * `lie_hom.range`
  * `lie_equiv.of_injective`
  * `lie_equiv.of_eq`
  * `lie_equiv.of_subalgebra`
  * `lie_equiv.of_subalgebras`

## Tags

lie algebra, lie subalgebra
-/

universes u v w w₁ w₂

section lie_subalgebra

variables (R : Type u) (L : Type v) [comm_ring R] [lie_ring L] [lie_algebra R L]

/-- A Lie subalgebra of a Lie algebra is submodule that is closed under the Lie bracket.
This is a sufficient condition for the subset itself to form a Lie algebra. -/
structure lie_subalgebra extends submodule R L :=
(lie_mem' : ∀ {x y}, x ∈ carrier → y ∈ carrier → ⁅x, y⁆ ∈ carrier)

attribute [nolint doc_blame] lie_subalgebra.to_submodule

/-- The zero algebra is a subalgebra of any Lie algebra. -/
instance : has_zero (lie_subalgebra R L) :=
⟨{ lie_mem' := λ x y hx hy, by { rw [((submodule.mem_bot R).1 hx), zero_lie],
                                exact submodule.zero_mem (0 : submodule R L), },
   ..(0 : submodule R L) }⟩

instance : inhabited (lie_subalgebra R L) := ⟨0⟩
instance : has_coe (lie_subalgebra R L) (submodule R L) := ⟨lie_subalgebra.to_submodule⟩
instance : has_mem L (lie_subalgebra R L) := ⟨λ x L', x ∈ (L' : set L)⟩

namespace lie_subalgebra

/-- A Lie subalgebra forms a new Lie ring. -/
instance (L' : lie_subalgebra R L) : lie_ring L' :=
{ bracket      := λ x y, ⟨⁅x.val, y.val⁆, L'.lie_mem' x.property y.property⟩,
  lie_add      := by { intros, apply set_coe.ext, apply lie_add, },
  add_lie      := by { intros, apply set_coe.ext, apply add_lie, },
  lie_self     := by { intros, apply set_coe.ext, apply lie_self, },
  leibniz_lie  := by { intros, apply set_coe.ext, apply leibniz_lie, } }

section

variables {R₁ : Type*} [semiring R₁]

/-- A Lie subalgebra inherits module structures from `L`. -/
instance [has_scalar R₁ R] [module R₁ L] [is_scalar_tower R₁ R L]
  (L' : lie_subalgebra R L) : module R₁ L' :=
L'.to_submodule.module'

instance [has_scalar R₁ R] [has_scalar R₁ᵐᵒᵖ R] [module R₁ L] [module R₁ᵐᵒᵖ L]
  [is_scalar_tower R₁ R L] [is_scalar_tower R₁ᵐᵒᵖ R L] [is_central_scalar R₁ L]
  (L' : lie_subalgebra R L) : is_central_scalar R₁ L' :=
L'.to_submodule.is_central_scalar

instance [has_scalar R₁ R] [module R₁ L] [is_scalar_tower R₁ R L]
  (L' : lie_subalgebra R L) : is_scalar_tower R₁ R L' :=
L'.to_submodule.is_scalar_tower

end

/-- A Lie subalgebra forms a new Lie algebra. -/
instance (L' : lie_subalgebra R L) : lie_algebra R L' :=
{ lie_smul := by { intros, apply set_coe.ext, apply lie_smul } }

variables {R L} (L' : lie_subalgebra R L)

@[simp] lemma zero_mem : (0 : L) ∈ L' := (L' : submodule R L).zero_mem

lemma smul_mem (t : R) {x : L} (h : x ∈ L') : t • x ∈ L' := (L' : submodule R L).smul_mem t h

lemma add_mem {x y : L} (hx : x ∈ L') (hy : y ∈ L') : (x + y : L) ∈ L' :=
(L' : submodule R L).add_mem hx hy

lemma sub_mem {x y : L} (hx : x ∈ L') (hy : y ∈ L') : (x - y : L) ∈ L' :=
(L' : submodule R L).sub_mem hx hy

@[simp] lemma neg_mem_iff {x : L} : -x ∈ L' ↔ x ∈ L' := L'.to_submodule.neg_mem_iff

lemma lie_mem {x y : L} (hx : x ∈ L') (hy : y ∈ L') : (⁅x, y⁆ : L) ∈ L' := L'.lie_mem' hx hy

@[simp] lemma mem_carrier {x : L} : x ∈ L'.carrier ↔ x ∈ (L' : set L) := iff.rfl

@[simp] lemma mem_mk_iff (S : set L) (h₁ h₂ h₃ h₄) {x : L} :
  x ∈ (⟨⟨S, h₁, h₂, h₃⟩, h₄⟩ : lie_subalgebra R L) ↔ x ∈ S :=
iff.rfl

@[simp] lemma mem_coe_submodule {x : L} : x ∈ (L' : submodule R L) ↔ x ∈ L' := iff.rfl

lemma mem_coe {x : L} : x ∈ (L' : set L) ↔ x ∈ L' := iff.rfl

@[simp, norm_cast] lemma coe_bracket (x y : L') : (↑⁅x, y⁆ : L) = ⁅(↑x : L), ↑y⁆ := rfl

lemma ext_iff (x y : L') : x = y ↔ (x : L) = y := subtype.ext_iff

lemma coe_zero_iff_zero (x : L') : (x : L) = 0 ↔ x = 0 := (ext_iff L' x 0).symm

@[ext] lemma ext (L₁' L₂' : lie_subalgebra R L) (h : ∀ x, x ∈ L₁' ↔ x ∈ L₂') :
  L₁' = L₂' :=
by { cases L₁', cases L₂', simp only [], ext x, exact h x, }

lemma ext_iff' (L₁' L₂' : lie_subalgebra R L) : L₁' = L₂' ↔ ∀ x, x ∈ L₁' ↔ x ∈ L₂' :=
⟨λ h x, by rw h, ext L₁' L₂'⟩

@[simp] lemma mk_coe (S : set L) (h₁ h₂ h₃ h₄) :
  ((⟨⟨S, h₁, h₂, h₃⟩, h₄⟩ : lie_subalgebra R L) : set L) = S := rfl

@[simp] lemma coe_to_submodule_mk (p : submodule R L) (h) :
  (({lie_mem' := h, ..p} : lie_subalgebra R L) : submodule R L) = p :=
by { cases p, refl, }

lemma coe_injective : function.injective (coe : lie_subalgebra R L → set L) :=
by { rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩ h, congr' }

instance : set_like (lie_subalgebra R L) L := ⟨coe, coe_injective⟩

@[norm_cast] theorem coe_set_eq (L₁' L₂' : lie_subalgebra R L) :
  (L₁' : set L) = L₂' ↔ L₁' = L₂' := coe_injective.eq_iff

lemma to_submodule_injective :
  function.injective (coe : lie_subalgebra R L → submodule R L) :=
λ L₁' L₂' h, by { rw set_like.ext'_iff at h, rw ← coe_set_eq, exact h, }

@[simp] lemma coe_to_submodule_eq_iff (L₁' L₂' : lie_subalgebra R L) :
  (L₁' : submodule R L) = (L₂' : submodule R L) ↔ L₁' = L₂' :=
to_submodule_injective.eq_iff

@[norm_cast]
lemma coe_to_submodule : ((L' : submodule R L) : set L) = L' := rfl

section lie_module

variables {M : Type w} [add_comm_group M] [lie_ring_module L M]
variables {N : Type w₁} [add_comm_group N] [lie_ring_module L N] [module R N] [lie_module R L N]

/-- Given a Lie algebra `L` containing a Lie subalgebra `L' ⊆ L`, together with a Lie ring module
`M` of `L`, we may regard `M` as a Lie ring module of `L'` by restriction. -/
instance : lie_ring_module L' M :=
{ bracket     := λ x m, ⁅(x : L), m⁆,
  add_lie     := λ x y m, add_lie x y m,
  lie_add     := λ x y m, lie_add x y m,
  leibniz_lie := λ x y m, leibniz_lie x y m, }

@[simp] lemma coe_bracket_of_module (x : L') (m : M) : ⁅x, m⁆ = ⁅(x : L), m⁆ := rfl

variables [module R M] [lie_module R L M]

/-- Given a Lie algebra `L` containing a Lie subalgebra `L' ⊆ L`, together with a Lie module `M` of
`L`, we may regard `M` as a Lie module of `L'` by restriction. -/
instance : lie_module R L' M :=
{ smul_lie := λ t x m, by simp only [coe_bracket_of_module, smul_lie, submodule.coe_smul_of_tower],
  lie_smul := λ t x m, by simp only [coe_bracket_of_module, lie_smul], }

/-- An `L`-equivariant map of Lie modules `M → N` is `L'`-equivariant for any Lie subalgebra
`L' ⊆ L`. -/
def _root_.lie_module_hom.restrict_lie (f : M →ₗ⁅R,L⁆ N) (L' : lie_subalgebra R L) : M →ₗ⁅R,L'⁆ N :=
{ map_lie' := λ x m, f.map_lie ↑x m,
  .. (f : M →ₗ[R] N)}

@[simp] lemma _root_.lie_module_hom.coe_restrict_lie (f : M →ₗ⁅R,L⁆ N) :
  ⇑(f.restrict_lie L') = f :=
rfl

end lie_module

/-- The embedding of a Lie subalgebra into the ambient space as a morphism of Lie algebras. -/
def incl : L' →ₗ⁅R⁆ L :=
{ map_lie' := λ x y, by { simp only [linear_map.to_fun_eq_coe, submodule.subtype_apply], refl, },
  .. (L' : submodule R L).subtype, }

@[simp] lemma coe_incl : ⇑L'.incl = coe := rfl

/-- The embedding of a Lie subalgebra into the ambient space as a morphism of Lie modules. -/
def incl' : L' →ₗ⁅R,L'⁆ L :=
{ map_lie' := λ x y, by simp only [coe_bracket_of_module, linear_map.to_fun_eq_coe,
    submodule.subtype_apply, coe_bracket],
  .. (L' : submodule R L).subtype, }

@[simp] lemma coe_incl' : ⇑L'.incl' = coe := rfl

end lie_subalgebra

variables {R L} {L₂ : Type w} [lie_ring L₂] [lie_algebra R L₂]
variables (f : L →ₗ⁅R⁆ L₂)

namespace lie_hom

/-- The range of a morphism of Lie algebras is a Lie subalgebra. -/
def range : lie_subalgebra R L₂ :=
{ lie_mem' := λ x y,
    show x ∈ f.to_linear_map.range → y ∈ f.to_linear_map.range → ⁅x, y⁆ ∈ f.to_linear_map.range,
    by { repeat { rw linear_map.mem_range }, rintros ⟨x', hx⟩ ⟨y', hy⟩, refine ⟨⁅x', y'⁆, _⟩,
         rw [←hx, ←hy], change f ⁅x', y'⁆ = ⁅f x', f y'⁆, rw map_lie, },
  ..(f : L →ₗ[R] L₂).range }

@[simp] lemma range_coe : (f.range : set L₂) = set.range f :=
linear_map.range_coe ↑f

@[simp] lemma mem_range (x : L₂) : x ∈ f.range ↔ ∃ (y : L), f y = x := linear_map.mem_range

lemma mem_range_self (x : L) : f x ∈ f.range := linear_map.mem_range_self f x

/-- We can restrict a morphism to a (surjective) map to its range. -/
def range_restrict : L →ₗ⁅R⁆ f.range :=
{ map_lie' := λ x y, by { apply subtype.ext, exact f.map_lie x y, },
  ..(f : L →ₗ[R] L₂).range_restrict, }

@[simp] lemma range_restrict_apply (x : L) : f.range_restrict x = ⟨f x, f.mem_range_self x⟩ := rfl

lemma surjective_range_restrict : function.surjective (f.range_restrict) :=
begin
  rintros ⟨y, hy⟩,
  erw mem_range at hy, obtain ⟨x, rfl⟩ := hy,
  use x,
  simp only [subtype.mk_eq_mk, range_restrict_apply],
end

/-- A Lie algebra is equivalent to its range under an injective Lie algebra morphism. -/
noncomputable def equiv_range_of_injective (h : function.injective f) : L ≃ₗ⁅R⁆ f.range :=
lie_equiv.of_bijective f.range_restrict (λ x y hxy,
begin
  simp only [subtype.mk_eq_mk, range_restrict_apply] at hxy,
  exact h hxy,
end) f.surjective_range_restrict

@[simp] lemma equiv_range_of_injective_apply (h : function.injective f) (x : L) :
  f.equiv_range_of_injective h x = ⟨f x, mem_range_self f x⟩ :=
rfl

end lie_hom

lemma submodule.exists_lie_subalgebra_coe_eq_iff (p : submodule R L) :
  (∃ (K : lie_subalgebra R L), ↑K = p) ↔ ∀ (x y : L), x ∈ p → y ∈ p → ⁅x, y⁆ ∈ p :=
begin
  split,
  { rintros ⟨K, rfl⟩, exact K.lie_mem', },
  { intros h, use { lie_mem' := h, ..p }, exact lie_subalgebra.coe_to_submodule_mk p _, },
end

namespace lie_subalgebra

variables (K K' : lie_subalgebra R L) (K₂ : lie_subalgebra R L₂)

@[simp] lemma incl_range : K.incl.range = K :=
by { rw ← coe_to_submodule_eq_iff, exact (K : submodule R L).range_subtype, }

/-- The image of a Lie subalgebra under a Lie algebra morphism is a Lie subalgebra of the
codomain. -/
def map : lie_subalgebra R L₂ :=
{ lie_mem' := λ x y hx hy, by
  { erw submodule.mem_map at hx, rcases hx with ⟨x', hx', hx⟩, rw ←hx,
    erw submodule.mem_map at hy, rcases hy with ⟨y', hy', hy⟩, rw ←hy,
    erw submodule.mem_map,
    exact ⟨⁅x', y'⁆, K.lie_mem hx' hy', f.map_lie x' y'⟩, },
..((K : submodule R L).map (f : L →ₗ[R] L₂)) }

@[simp] lemma mem_map (x : L₂) : x ∈ K.map f ↔ ∃ (y : L), y ∈ K ∧ f y = x := submodule.mem_map

-- TODO Rename and state for homs instead of equivs.
@[simp] lemma mem_map_submodule (e : L ≃ₗ⁅R⁆ L₂) (x : L₂) :
  x ∈ K.map (e : L →ₗ⁅R⁆ L₂) ↔ x ∈ (K : submodule R L).map (e : L →ₗ[R] L₂) :=
iff.rfl

/-- The preimage of a Lie subalgebra under a Lie algebra morphism is a Lie subalgebra of the
domain. -/
def comap : lie_subalgebra R L :=
{ lie_mem' := λ x y hx hy, by
    { suffices : ⁅f x, f y⁆ ∈ K₂, by { simp [this], }, exact K₂.lie_mem hx hy, },
  ..((K₂ : submodule R L₂).comap (f : L →ₗ[R] L₂)), }

section lattice_structure

open set

instance : partial_order (lie_subalgebra R L) :=
{ le := λ N N', ∀ ⦃x⦄, x ∈ N → x ∈ N', -- Overriding `le` like this gives a better defeq.
  ..partial_order.lift (coe : lie_subalgebra R L → set L) coe_injective }

lemma le_def : K ≤ K' ↔ (K : set L) ⊆ K' := iff.rfl

@[simp, norm_cast] lemma coe_submodule_le_coe_submodule : (K : submodule R L) ≤ K' ↔ K ≤ K' :=
iff.rfl

instance : has_bot (lie_subalgebra R L) := ⟨0⟩

@[simp] lemma bot_coe : ((⊥ : lie_subalgebra R L) : set L) = {0} := rfl

@[simp] lemma bot_coe_submodule : ((⊥ : lie_subalgebra R L) : submodule R L) = ⊥ := rfl

@[simp] lemma mem_bot (x : L) : x ∈ (⊥ : lie_subalgebra R L) ↔ x = 0 := mem_singleton_iff

instance : has_top (lie_subalgebra R L) :=
⟨{ lie_mem' := λ x y hx hy, mem_univ ⁅x, y⁆,
   ..(⊤ : submodule R L) }⟩

@[simp] lemma top_coe : ((⊤ : lie_subalgebra R L) : set L) = univ := rfl

@[simp] lemma top_coe_submodule : ((⊤ : lie_subalgebra R L) : submodule R L) = ⊤ := rfl

@[simp] lemma mem_top (x : L) : x ∈ (⊤ : lie_subalgebra R L) := mem_univ x

lemma _root_.lie_hom.range_eq_map : f.range = map f ⊤ :=
by { ext, simp }

instance : has_inf (lie_subalgebra R L) :=
⟨λ K K', { lie_mem' := λ x y hx hy, mem_inter (K.lie_mem hx.1 hy.1) (K'.lie_mem hx.2 hy.2),
            ..(K ⊓ K' : submodule R L) }⟩

instance : has_Inf (lie_subalgebra R L) :=
⟨λ S, { lie_mem' := λ x y hx hy, by
        { simp only [submodule.mem_carrier, mem_Inter, submodule.Inf_coe, mem_set_of_eq,
            forall_apply_eq_imp_iff₂, exists_imp_distrib] at *,
          intros K hK, exact K.lie_mem (hx K hK) (hy K hK), },
        ..Inf {(s : submodule R L) | s ∈ S} }⟩

@[simp] theorem inf_coe : (↑(K ⊓ K') : set L) = K ∩ K' := rfl

@[simp] lemma Inf_coe_to_submodule (S : set (lie_subalgebra R L)) :
  (↑(Inf S) : submodule R L) = Inf {(s : submodule R L) | s ∈ S} := rfl

@[simp] lemma Inf_coe (S : set (lie_subalgebra R L)) : (↑(Inf S) : set L) = ⋂ s ∈ S, (s : set L) :=
begin
  rw [← coe_to_submodule, Inf_coe_to_submodule, submodule.Inf_coe],
  ext x,
  simpa only [mem_Inter, mem_set_of_eq, forall_apply_eq_imp_iff₂, exists_imp_distrib],
end

lemma Inf_glb (S : set (lie_subalgebra R L)) : is_glb S (Inf S) :=
begin
  have h : ∀ (K K' : lie_subalgebra R L), (K : set L) ≤ K' ↔ K ≤ K', { intros, exact iff.rfl, },
  apply is_glb.of_image h,
  simp only [Inf_coe],
  exact is_glb_binfi
end

/-- The set of Lie subalgebras of a Lie algebra form a complete lattice.

We provide explicit values for the fields `bot`, `top`, `inf` to get more convenient definitions
than we would otherwise obtain from `complete_lattice_of_Inf`. -/
instance : complete_lattice (lie_subalgebra R L) :=
{ bot          := ⊥,
  bot_le       := λ N _ h, by { rw mem_bot at h, rw h, exact N.zero_mem', },
  top          := ⊤,
  le_top       := λ _ _ _, trivial,
  inf          := (⊓),
  le_inf       := λ N₁ N₂ N₃ h₁₂ h₁₃ m hm, ⟨h₁₂ hm, h₁₃ hm⟩,
  inf_le_left  := λ _ _ _, and.left,
  inf_le_right := λ _ _ _, and.right,
  ..complete_lattice_of_Inf _ Inf_glb }

instance : add_comm_monoid (lie_subalgebra R L) :=
{ add       := (⊔),
  add_assoc := λ _ _ _, sup_assoc,
  zero      := ⊥,
  zero_add  := λ _, bot_sup_eq,
  add_zero  := λ _, sup_bot_eq,
  add_comm  := λ _ _, sup_comm, }

@[simp] lemma add_eq_sup : K + K' = K ⊔ K' := rfl

@[norm_cast, simp] lemma inf_coe_to_submodule :
  (↑(K ⊓ K') : submodule R L) = (K : submodule R L) ⊓ (K' : submodule R L) := rfl

@[simp] lemma mem_inf (x : L) : x ∈ K ⊓ K' ↔ x ∈ K ∧ x ∈ K' :=
by rw [← mem_coe_submodule, ← mem_coe_submodule, ← mem_coe_submodule, inf_coe_to_submodule,
  submodule.mem_inf]

lemma eq_bot_iff : K = ⊥ ↔ ∀ (x : L), x ∈ K → x = 0 :=
by { rw eq_bot_iff, exact iff.rfl, }

-- TODO[gh-6025]: make this an instance once safe to do so
lemma subsingleton_of_bot : subsingleton (lie_subalgebra R ↥(⊥ : lie_subalgebra R L)) :=
begin
  apply subsingleton_of_bot_eq_top,
  ext ⟨x, hx⟩, change x ∈ ⊥ at hx, rw submodule.mem_bot at hx, subst hx,
  simp only [true_iff, eq_self_iff_true, submodule.mk_eq_zero, mem_bot],
end

variables (R L)

lemma well_founded_of_noetherian [is_noetherian R L] :
  well_founded ((>) : lie_subalgebra R L → lie_subalgebra R L → Prop) :=
  let f : ((>) : lie_subalgebra R L → lie_subalgebra R L → Prop) →r
          ((>) : submodule R L → submodule R L → Prop) :=
  { to_fun       := coe,
    map_rel' := λ N N' h, h, }
in rel_hom_class.well_founded f (is_noetherian_iff_well_founded.mp infer_instance)

variables {R L K K' f}

section nested_subalgebras

variables (h : K ≤ K')

/-- Given two nested Lie subalgebras `K ⊆ K'`, the inclusion `K ↪ K'` is a morphism of Lie
algebras. -/
def hom_of_le : K →ₗ⁅R⁆ K' :=
{ map_lie' := λ x y, rfl,
  ..submodule.of_le h }

@[simp] lemma coe_hom_of_le (x : K) : (hom_of_le h x : L) = x := rfl

lemma hom_of_le_apply (x : K) : hom_of_le h x = ⟨x.1, h x.2⟩ := rfl

lemma hom_of_le_injective : function.injective (hom_of_le h) :=
λ x y, by simp only [hom_of_le_apply, imp_self, subtype.mk_eq_mk, set_like.coe_eq_coe,
  subtype.val_eq_coe]

/-- Given two nested Lie subalgebras `K ⊆ K'`, we can view `K` as a Lie subalgebra of `K'`,
regarded as Lie algebra in its own right. -/
def of_le : lie_subalgebra R K' := (hom_of_le h).range

@[simp] lemma mem_of_le (x : K') : x ∈ of_le h ↔ (x : L) ∈ K :=
begin
  simp only [of_le, hom_of_le_apply, lie_hom.mem_range],
  split,
  { rintros ⟨y, rfl⟩, exact y.property, },
  { intros h, use ⟨(x : L), h⟩, simp, },
end

lemma of_le_eq_comap_incl : of_le h = K.comap K'.incl :=
by { ext, rw mem_of_le, refl, }

@[simp] lemma coe_of_le : (of_le h : submodule R K') = (submodule.of_le h).range := rfl

/-- Given nested Lie subalgebras `K ⊆ K'`, there is a natural equivalence from `K` to its image in
`K'`.  -/
noncomputable def equiv_of_le : K ≃ₗ⁅R⁆ of_le h :=
(hom_of_le h).equiv_range_of_injective (hom_of_le_injective h)

@[simp]

end nested_subalgebras

lemma map_le_iff_le_comap {K : lie_subalgebra R L} {K' : lie_subalgebra R L₂} :
  map f K ≤ K' ↔ K ≤ comap f K' := set.image_subset_iff

lemma gc_map_comap : galois_connection (map f) (comap f) := λ K K', map_le_iff_le_comap

end lattice_structure

section lie_span

variables (R L) (s : set L)

/-- The Lie subalgebra of a Lie algebra `L` generated by a subset `s ⊆ L`. -/
def lie_span : lie_subalgebra R L := Inf {N | s ⊆ N}

variables {R L s}

lemma mem_lie_span {x : L} : x ∈ lie_span R L s ↔ ∀ K : lie_subalgebra R L, s ⊆ K → x ∈ K :=
by { change x ∈ (lie_span R L s : set L) ↔ _, erw Inf_coe, exact set.mem_Inter₂, }

lemma subset_lie_span : s ⊆ lie_span R L s :=
by { intros m hm, erw mem_lie_span, intros K hK, exact hK hm, }

lemma submodule_span_le_lie_span : submodule.span R s ≤ lie_span R L s :=
by { rw submodule.span_le, apply subset_lie_span, }

lemma lie_span_le {K} : lie_span R L s ≤ K ↔ s ⊆ K :=
begin
  split,
  { exact set.subset.trans subset_lie_span, },
  { intros hs m hm, rw mem_lie_span at hm, exact hm _ hs, },
end

lemma lie_span_mono {t : set L} (h : s ⊆ t) : lie_span R L s ≤ lie_span R L t :=
by { rw lie_span_le, exact set.subset.trans h subset_lie_span, }

lemma lie_span_eq : lie_span R L (K : set L) = K :=
le_antisymm (lie_span_le.mpr rfl.subset) subset_lie_span

lemma coe_lie_span_submodule_eq_iff {p : submodule R L} :
  (lie_span R L (p : set L) : submodule R L) = p ↔ ∃ (K : lie_subalgebra R L), ↑K = p :=
begin
  rw p.exists_lie_subalgebra_coe_eq_iff, split; intros h,
  { intros x m hm, rw [← h, mem_coe_submodule], exact lie_mem _ (subset_lie_span hm), },
  { rw [← coe_to_submodule_mk p h, coe_to_submodule, coe_to_submodule_eq_iff, lie_span_eq], },
end

variables (R L)

/-- `lie_span` forms a Galois insertion with the coercion from `lie_subalgebra` to `set`. -/
protected def gi : galois_insertion (lie_span R L : set L → lie_subalgebra R L) coe :=
{ choice    := λ s _, lie_span R L s,
  gc        := λ s t, lie_span_le,
  le_l_u    := λ s, subset_lie_span,
  choice_eq := λ s h, rfl }

@[simp] lemma span_empty : lie_span R L (∅ : set L) = ⊥ :=
(lie_subalgebra.gi R L).gc.l_bot

@[simp] lemma span_univ : lie_span R L (set.univ : set L) = ⊤ :=
eq_top_iff.2 $ set_like.le_def.2 $ subset_lie_span

variables {L}

lemma span_union (s t : set L) : lie_span R L (s ∪ t) = lie_span R L s ⊔ lie_span R L t :=
(lie_subalgebra.gi R L).gc.l_sup

lemma span_Union {ι} (s : ι → set L) : lie_span R L (⋃ i, s i) = ⨆ i, lie_span R L (s i) :=
(lie_subalgebra.gi R L).gc.l_supr

end lie_span

end lie_subalgebra

end lie_subalgebra

namespace lie_equiv

variables {R : Type u} {L₁ : Type v} {L₂ : Type w}
variables [comm_ring R] [lie_ring L₁] [lie_ring L₂] [lie_algebra R L₁] [lie_algebra R L₂]

/-- An injective Lie algebra morphism is an equivalence onto its range. -/
noncomputable def of_injective (f : L₁ →ₗ⁅R⁆ L₂) (h : function.injective f) :
  L₁ ≃ₗ⁅R⁆ f.range :=
{ map_lie' := λ x y, by { apply set_coe.ext, simpa, },
..(linear_equiv.of_injective ↑f $ by rwa [lie_hom.coe_to_linear_map])}

@[simp] lemma of_injective_apply (f : L₁ →ₗ⁅R⁆ L₂) (h : function.injective f) (x : L₁) :
  ↑(of_injective f h x) = f x := rfl

variables (L₁' L₁'' : lie_subalgebra R L₁) (L₂' : lie_subalgebra R L₂)

/-- Lie subalgebras that are equal as sets are equivalent as Lie algebras. -/
def of_eq (h : (L₁' : set L₁) = L₁'') : L₁' ≃ₗ⁅R⁆ L₁'' :=
{ map_lie' := λ x y, by { apply set_coe.ext, simp, },
  ..(linear_equiv.of_eq ↑L₁' ↑L₁''
      (by {ext x, change x ∈ (L₁' : set L₁) ↔ x ∈ (L₁'' : set L₁), rw h, } )) }

@[simp] lemma of_eq_apply (L L' : lie_subalgebra R L₁) (h : (L : set L₁) = L') (x : L) :
  (↑(of_eq L L' h x) : L₁) = x := rfl

variables (e : L₁ ≃ₗ⁅R⁆ L₂)

/-- An equivalence of Lie algebras restricts to an equivalence from any Lie subalgebra onto its
image. -/
def lie_subalgebra_map : L₁'' ≃ₗ⁅R⁆ (L₁''.map e : lie_subalgebra R L₂) :=
{ map_lie' := λ x y, by { apply set_coe.ext, exact lie_hom.map_lie (↑e : L₁ →ₗ⁅R⁆ L₂) ↑x ↑y, }
  ..(linear_equiv.submodule_map (e : L₁ ≃ₗ[R] L₂) ↑L₁'') }

@[simp] lemma lie_subalgebra_map_apply (x : L₁'') : ↑(e.lie_subalgebra_map _  x) = e x := rfl

/-- An equivalence of Lie algebras restricts to an equivalence from any Lie subalgebra onto its
image. -/
def of_subalgebras (h : L₁'.map ↑e = L₂') : L₁' ≃ₗ⁅R⁆ L₂' :=
{ map_lie' := λ x y, by { apply set_coe.ext, exact lie_hom.map_lie (↑e : L₁ →ₗ⁅R⁆ L₂) ↑x ↑y, },
  ..(linear_equiv.of_submodules (e : L₁ ≃ₗ[R] L₂) ↑L₁' ↑L₂' (by { rw ←h, refl, })) }

@[simp] lemma of_subalgebras_apply (h : L₁'.map ↑e = L₂') (x : L₁') :
  ↑(e.of_subalgebras _ _ h x) = e x := rfl

@[simp] lemma of_subalgebras_symm_apply (h : L₁'.map ↑e = L₂') (x : L₂') :
  ↑((e.of_subalgebras _ _ h).symm x) = e.symm x := rfl

end lie_equiv


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

! This file was ported from Lean 3 source module category_theory.sites.surjective
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Sites.Subsheaf
import Mathbin.CategoryTheory.Sites.CompatibleSheafification

/-!

# Locally surjective morphisms

## Main definitions

- `is_locally_surjective` : A morphism of presheaves valued in a concrete category is locally
  surjective with respect to a grothendieck topology if every section in the target is locally
  in the set-theoretic image, i.e. the image sheaf coincides with the target.

## Main results

- `to_sheafify_is_locally_surjective` : `to_sheafify` is locally surjective.

-/

universe v u w v' u' w'

open Opposite CategoryTheory CategoryTheory.GrothendieckTopology

namespace CategoryTheory

variable {C : Type u} [Category.{v} C] (J : GrothendieckTopology C)

attribute [local instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

variable {A : Type u'} [Category.{v'} A] [ConcreteCategory.{w'} A]

/-- Given `f : F ⟶ G`, a morphism between presieves, and `s : G.obj (op U)`, this is the sieve
of `U` consisting of the `i : V ⟶ U` such that `s` restricted along `i` is in the image of `f`. -/
@[simps (config := lemmasOnly)]
def imageSieve {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) {U : C} (s : G.obj (op U)) : Sieve U
    where
  arrows V i := ∃ t : F.obj (op V), f.app _ t = G.map i.op s
  downward_closed' := by
    rintro V W i ⟨t, ht⟩ j
    refine' ⟨F.map j.op t, _⟩
    rw [op_comp, G.map_comp, comp_apply, ← ht, elementwise_of f.naturality]
#align category_theory.image_sieve CategoryTheory.imageSieve

theorem imageSieve_eq_sieveOfSection {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) {U : C} (s : G.obj (op U)) :
    imageSieve f s = (imagePresheaf (whiskerRight f (forget A))).sieveOfSection s :=
  rfl
#align category_theory.image_sieve_eq_sieve_of_section CategoryTheory.imageSieve_eq_sieveOfSection

theorem imageSieve_whisker_forget {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) {U : C} (s : G.obj (op U)) :
    imageSieve (whiskerRight f (forget A)) s = imageSieve f s :=
  rfl
#align category_theory.image_sieve_whisker_forget CategoryTheory.imageSieve_whisker_forget

theorem imageSieve_app {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) {U : C} (s : F.obj (op U)) :
    imageSieve f (f.app _ s) = ⊤ := by
  ext (V i)
  simp only [sieve.top_apply, iff_true_iff, image_sieve_apply]
  have := elementwise_of (f.naturality i.op)
  exact ⟨F.map i.op s, this s⟩
#align category_theory.image_sieve_app CategoryTheory.imageSieve_app

/-- A morphism of presheaves `f : F ⟶ G` is locally surjective with respect to a grothendieck
topology if every section of `G` is locally in the image of `f`. -/
def IsLocallySurjective {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) : Prop :=
  ∀ (U : C) (s : G.obj (op U)), imageSieve f s ∈ J U
#align category_theory.is_locally_surjective CategoryTheory.IsLocallySurjective

theorem isLocallySurjective_iff_imagePresheaf_sheafify_eq_top {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) :
    IsLocallySurjective J f ↔ (imagePresheaf (whiskerRight f (forget A))).sheafify J = ⊤ :=
  by
  simp only [subpresheaf.ext_iff, Function.funext_iff, Set.ext_iff, top_subpresheaf_obj,
    Set.top_eq_univ, Set.mem_univ, iff_true_iff]
  exact ⟨fun H U => H (unop U), fun H U => H (op U)⟩
#align category_theory.is_locally_surjective_iff_image_presheaf_sheafify_eq_top CategoryTheory.isLocallySurjective_iff_imagePresheaf_sheafify_eq_top

theorem isLocallySurjective_iff_imagePresheaf_sheafify_eq_top' {F G : Cᵒᵖ ⥤ Type w} (f : F ⟶ G) :
    IsLocallySurjective J f ↔ (imagePresheaf f).sheafify J = ⊤ :=
  by
  simp only [subpresheaf.ext_iff, Function.funext_iff, Set.ext_iff, top_subpresheaf_obj,
    Set.top_eq_univ, Set.mem_univ, iff_true_iff]
  exact ⟨fun H U => H (unop U), fun H U => H (op U)⟩
#align category_theory.is_locally_surjective_iff_image_presheaf_sheafify_eq_top' CategoryTheory.isLocallySurjective_iff_imagePresheaf_sheafify_eq_top'

theorem isLocallySurjective_iff_isIso {F G : Sheaf J (Type w)} (f : F ⟶ G) :
    IsLocallySurjective J f.1 ↔ IsIso (imageSheafι f) :=
  by
  rw [image_sheaf_ι, is_locally_surjective_iff_image_presheaf_sheafify_eq_top',
    subpresheaf.eq_top_iff_is_iso]
  exact
    ⟨fun h => @is_iso_of_reflects_iso _ _ (image_sheaf_ι f) (Sheaf_to_presheaf J _) h _, fun h =>
      @functor.map_is_iso _ _ (Sheaf_to_presheaf J _) _ h⟩
#align category_theory.is_locally_surjective_iff_is_iso CategoryTheory.isLocallySurjective_iff_isIso

theorem isLocallySurjective_iff_whisker_forget {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) :
    IsLocallySurjective J f ↔ IsLocallySurjective J (whiskerRight f (forget A)) := by
  simpa only [is_locally_surjective_iff_image_presheaf_sheafify_eq_top]
#align category_theory.is_locally_surjective_iff_whisker_forget CategoryTheory.isLocallySurjective_iff_whisker_forget

theorem isLocallySurjective_of_surjective {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G)
    (H : ∀ U, Function.Surjective (f.app U)) : IsLocallySurjective J f :=
  by
  intro U s
  obtain ⟨t, rfl⟩ := H _ s
  rw [image_sieve_app]
  exact J.top_mem _
#align category_theory.is_locally_surjective_of_surjective CategoryTheory.isLocallySurjective_of_surjective

theorem isLocallySurjective_of_iso {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) [IsIso f] :
    IsLocallySurjective J f :=
  by
  apply is_locally_surjective_of_surjective
  intro U
  apply Function.Bijective.surjective
  rw [← is_iso_iff_bijective]
  infer_instance
#align category_theory.is_locally_surjective_of_iso CategoryTheory.isLocallySurjective_of_iso

theorem IsLocallySurjective.comp {F₁ F₂ F₃ : Cᵒᵖ ⥤ A} {f₁ : F₁ ⟶ F₂} {f₂ : F₂ ⟶ F₃}
    (h₁ : IsLocallySurjective J f₁) (h₂ : IsLocallySurjective J f₂) :
    IsLocallySurjective J (f₁ ≫ f₂) := by
  intro U s
  have :
    (sieve.bind (image_sieve f₂ s) fun _ _ h => image_sieve f₁ h.some) ≤ image_sieve (f₁ ≫ f₂) s :=
    by
    rintro V i ⟨W, i, j, H, ⟨t', ht'⟩, rfl⟩
    refine' ⟨t', _⟩
    rw [op_comp, F₃.map_comp, nat_trans.comp_app, comp_apply, comp_apply, ht',
      elementwise_of f₂.naturality, H.some_spec]
  apply J.superset_covering this
  apply J.bind_covering
  · apply h₂
  · intros
    apply h₁
#align category_theory.is_locally_surjective.comp CategoryTheory.IsLocallySurjective.comp

section

variable (F : Cᵒᵖ ⥤ Type max u v)

/-- The image of `F` in `J.sheafify F` is isomorphic to the sheafification. -/
noncomputable def sheafificationIsoImagePresheaf :
    J.sheafify F ≅ ((imagePresheaf (J.toSheafify F)).sheafify J).toPresheaf
    where
  Hom :=
    J.sheafifyLift (toImagePresheafSheafify J _)
      ((isSheaf_iff_isSheaf_of_type J _).mpr <|
        Subpresheaf.sheafify_isSheaf _ <|
          (isSheaf_iff_isSheaf_of_type J _).mp <| sheafify_isSheaf J _)
  inv := Subpresheaf.ι _
  hom_inv_id' :=
    J.sheafify_hom_ext _ _ (J.sheafify_isSheaf _) (by simp [to_image_presheaf_sheafify])
  inv_hom_id' :=
    by
    rw [← cancel_mono (subpresheaf.ι _), category.id_comp, category.assoc]
    refine' Eq.trans _ (category.comp_id _)
    congr 1
    exact J.sheafify_hom_ext _ _ (J.sheafify_is_sheaf _) (by simp [to_image_presheaf_sheafify])
    infer_instance
#align category_theory.sheafification_iso_image_presheaf CategoryTheory.sheafificationIsoImagePresheaf

-- We need to sheafify
variable {B : Type w} [Category.{max u v} B] [ConcreteCategory.{max u v} B]
  [∀ X : C, Limits.HasColimitsOfShape (J.cover X)ᵒᵖ B]
  [∀ (P : Cᵒᵖ ⥤ B) (X : C) (S : J.cover X), Limits.HasMultiequalizer (S.index P)]
  [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ B),
      Limits.PreservesLimit (W.index P).multicospan (forget B)]
  [∀ X : C, Limits.PreservesColimitsOfShape (J.cover X)ᵒᵖ (forget B)]
  [∀ (α β : Type max u v) (fst snd : β → α),
      Limits.HasLimitsOfShape (Limits.WalkingMulticospan fst snd) B]

theorem toSheafify_isLocallySurjective (F : Cᵒᵖ ⥤ B) : IsLocallySurjective J (J.toSheafify F) :=
  by
  rw [is_locally_surjective_iff_whisker_forget, ← to_sheafify_comp_sheafify_comp_iso_inv]
  apply is_locally_surjective.comp
  · rw [is_locally_surjective_iff_image_presheaf_sheafify_eq_top, subpresheaf.eq_top_iff_is_iso]
    exact is_iso.of_iso_inv (sheafification_iso_image_presheaf J (F ⋙ forget B))
  · exact is_locally_surjective_of_iso _ _
#align category_theory.to_sheafify_is_locally_surjective CategoryTheory.toSheafify_isLocallySurjective

end

end CategoryTheory


import formula
import semantics
import data.list.alist
import data.subtype

variables {vars : Type} [denumerable vars]
variables {A B C : form vars} {p q r : vars}

/-- A schema is the set of substitution instances of some formula A. A is called
the *characteristic* formula of the schema, which is unique up to a renaming of
variables. -/
def schema (A : form vars) := {B | ∃s, subst.apply s A = B}

/-- A renaming of variables is a mapping from variables to variables. -/
def rename (vars : Type) [decidable_eq vars] : Type :=
  { r : subst vars //
    -- r maps only to variables
    (∀ x, (r.lookup x).is_some → ∃ y, (⦃y⦄ ∈ r.lookup x)) ∧
    -- r is injective
    (∀ x y, r.lookup x = r.lookup y →
           (r.lookup x).is_some → (r.lookup y).is_some → x = y) }

def rename.apply (r : rename vars) := subst.apply (r.val)

def rename.union (r₁ r₂ : rename vars) : rename vars := ⟨r₁.val ∪ r₂.val, sorry⟩

instance : has_union (rename vars) := ⟨rename.union⟩
instance : has_mem vars (rename vars) := ⟨λ x r, x ∈ r.val⟩
instance : has_emptyc (rename vars) := ⟨⟨∅, by simp⟩⟩

universes u v

@[simp]
theorem list.lookup_cons_not_mem {α : Type u} {β : α → Type v} [decidable_eq α]
(l : list (sigma β)) {a : α} (s : sigma β)
: a ∉ l.keys → ((list.lookup a (s :: l)).is_some ↔ a = s.fst) :=
begin
  rcases s with ⟨s_fst, s_snd⟩,
  simp only,
  intro ha,
  split,
  { intro hsome,
    simp only [list.lookup] at hsome,
    split_ifs at hsome,
    { simp only [h] },
    { rw list.lookup_is_some at hsome, exfalso, exact ha hsome }
  },
  {
    rintro rfl,
    simp only [list.lookup_cons_eq, option.is_some_some, coe_sort_tt],
  }
end

theorem schema.characteristic_unique_up_to_renaming (h : schema A = schema B)
  : ∃ (r : rename vars), r.apply A = B :=
begin
  simp [set.ext_iff, schema] at h,
  induction A generalizing B,
  case form.Bottom {
    simp [subst.apply] at ⊢ h,
    specialize h B,
    cases h.mpr ⟨∅, subst.apply_empty_id⟩ with _ this,
    exact ⟨∅, this⟩,
  },
  case form.Var : a {
    cases B,
    case form.Var : b {
      -- the renaming just takes variable a to b
      set r : rename vars := ⟨⟨[⟨a, ⦃b⦄⟩], (by simp)⟩, by {
        simp [alist.lookup],
        intros x y hxy hx hy,
        rw [hx, hy]
      }⟩ with hr,
      use r,
      simp [rename.apply, subst.apply, subst.get, alist.lookup, hr,
            sigma.map, list.lookup],
    },
    all_goals {
      -- If B is some connective, then it cannot be
      -- substituted to become ⦃A⦄, which contradicts h
      exfalso,
      cases (h ⦃a⦄).mp ⟨∅, subst.apply_empty_id⟩ with s this,
      simp only [subst.apply] at this,
      exact this
    },
  },
  case form.Not : A ih {
    cases B,
    case form.Not : b {
      simp only [rename.apply, subst.apply] at ⊢ h,
      -- Now we know that the variable x in h has to be of the form (~ x), which
      -- means we can simplify it to the following:
      have : ∀ (x : form vars), (∃ (s : subst vars), s.apply A = x) ↔
                                (∃ (s : subst vars), s.apply b = x),
        intro x,
        specialize h (~x),
        simp only at h,
        exact h,
      -- which is exactly what we need to use the ih
      exact ih this,
    },
    case form.Var {
      -- if B is a variable, then ~A cannot be substituted to become B,
      -- but this contradicts h
      exfalso,
      cases (h ⦃B⦄).mpr ⟨∅, subst.apply_empty_id⟩ with s this,
      simp only [subst.apply] at this,
      exact this
    },
    all_goals {
      exfalso,
      cases (h (~A)).mp ⟨∅, subst.apply_empty_id⟩ with s this,
      simp only [subst.apply] at this,
      exact this
    }
  },
  case form.And : A₁ A₂ ih₁ ih₂  {
    cases B,
    case form.And : B₁ B₂ {
      simp only [rename.apply, subst.apply] at ⊢ h,
      -- Now we know that the variable x in h has to be of the form (x₁ ⋀ x₂),
      -- which means we can simplify it to the following:
      have : ∀ (x₁ x₂ : form vars),
        (∃ (s : subst vars), s.apply A₁ = x₁ ∧ s.apply A₂ = x₂) ↔
        (∃ (s : subst vars), s.apply B₁ = x₁ ∧ s.apply B₂ = x₂),
        intros x₁ x₂,
        specialize h (x₁ ⋀ x₂),
        simp only at h,
        exact h,
      have hAB₁ : ∀ (x : form vars),
        (∃ (s : subst vars), s.apply A₁ = x) ↔
        (∃ (s : subst vars), s.apply B₁ = x),
        intros x,
        split,
        { rintro ⟨sA₁, hA₁⟩,
          obtain ⟨sB₁, hB₁, _⟩ := (this x (sA₁.apply A₂)).mp ⟨sA₁, hA₁, rfl⟩,
          exact ⟨sB₁, hB₁⟩
        },
        { rintro ⟨sB₁, hB₁⟩,
          obtain ⟨sA₁, hA₁, _⟩ := (this x (sB₁.apply B₂)).mpr ⟨sB₁, hB₁, rfl⟩,
          exact ⟨sA₁, hA₁⟩
        },
      have hAB₂ : ∀ (x : form vars),
        (∃ (s : subst vars), s.apply A₂ = x) ↔
        (∃ (s : subst vars), s.apply B₂ = x),
        intros x,
        split,
        { rintro ⟨sA₂, hA₂⟩,
          obtain ⟨sB₂, _, hB₂⟩ := (this (sA₂.apply A₁) x).mp ⟨sA₂, rfl, hA₂⟩,
          exact ⟨sB₂, hB₂⟩
        },
        { rintro ⟨sB₂, hB₂⟩,
          obtain ⟨sA₂, _, hA₂⟩ := (this (sB₂.apply B₁) x).mpr ⟨sB₂, rfl, hB₂⟩,
          exact ⟨sA₂, hA₂⟩
        },
      obtain ⟨r₁, hr₁⟩ := ih₁ hAB₁,
      obtain ⟨r₂, hr₂⟩ := ih₂ hAB₂,
      use r₁ ∪ r₂,
      split,
      simp [has_union.union, rename.union, subst.apply],
      sorry, sorry
    },
    case form.Var {
      exfalso,
      cases (h ⦃B⦄).mpr ⟨∅, subst.apply_empty_id⟩ with s this,
      simp only [subst.apply] at this,
      exact this
    },
    all_goals {
      exfalso,
      cases (h (A₁ ⋀ A₂)).mp ⟨∅, subst.apply_empty_id⟩ with s this,
      simp only [subst.apply] at this,
      exact this
    }
  },
  -- the remaining connectives will have basically the same proof as either
  -- form.Not or form.And
  sorry,
  sorry,
  sorry,
end

def eval_schema (M : model vars) (S : set (form vars)) := ∀ B ∈ S, M ⊩ B
notation M ` ⊨ ` S := eval_schema M S
notation M ` ⊭ ` S := ¬ eval_schema M S

def valid_schema (S : set (form vars)) :=
∀ M : model vars, M ⊨ S

example : valid_schema (schema (□ (⦃p⦄ ⟹ ⦃q⦄) ⟹ □ ⦃p⦄ ⟹ □ ⦃q⦄)) :=
begin
  intros M C hC w,
  simp only [schema, subst.apply, set.mem_set_of_eq] at hC,
  cases hC with s hC,
  rw ←hC,
  simp [eval],
  intros hAB hA w' hrel,
  exact hAB w' hrel (hA w' hrel)
end

lemma eval_instance_iff_eval {A : form vars} {W : Type} [nonempty W]
{R : W → W → Prop} {V V' : vars → set W} {w : W}
{s : subst vars} (hM' : ∀ x, V' x = {w | ⟪W, R, V⟫ @@ w ⊩ s.get x})
: (⟪W, R, V⟫ @@ w ⊩ s.apply A) ↔ (⟪W, R, V'⟫ @@ w ⊩ A)
:= begin
  induction A generalizing w,
  case form.Bottom {
    simp only [subst.apply, bottom_eq_bot, eval],
  },
  case form.Var {
    simp only [subst.apply, eval, hM' A, set.mem_set_of_eq],
  },
  case form.Not : A ih {
    simp only [subst.apply, eval, not_iff_not, ih],
  },
  case form.And : A₁ A₂ ih₁ ih₂ {
    simp only [subst.apply, eval, ih₁, ih₂],
  },
  case form.Or : A₁ A₂ ih₁ ih₂ {
    simp only [subst.apply, eval, ih₁, ih₂],
  },
  case form.Imply : A₁ A₂ ih₁ ih₂ {
    simp only [subst.apply, eval, ih₁, ih₂],
  },
  case form.Box : A ih {
    simp only [subst.apply, eval],
    split,
    { intros h w' hw', specialize h w' hw', exact ih.mp h },
    { intros h w' hw', specialize h w' hw', exact ih.mpr h }
  }
end

/-- This is a generalisation of tautological_instance_is_valid where we have
substitutions over arbitrary formulas, not just tautologies. -/
theorem valid_schema_iff_valid : valid_schema (schema A) ↔ valid A :=
begin
  split,
  -- the left-to-right direction is easy since A must be in its own schema.
  { intros hv M w, exact hv M A ⟨∅, subst.apply_empty_id⟩ w },
  rintros hv ⟨⟨W, hnonempty, R⟩, V⟩ A' ⟨s, rfl⟩ w,
  resetI,
  by_contra h,
  -- We construct M' that re-assigns variables based on the truth value of their substitutions in the original model M.
  set V' := λ x, {w | ⟪W, R, V⟫@@w ⊩ s.get x} with hV',
  set M' : model vars := ⟪W, R, V'⟫ with hM',
  have this := congr_fun hV',
  dsimp at this,
  -- Hence, whenever the substituted formula A' holds in the original model,
  -- the pre-substituted formula A holds in our new model. This is represented
  -- by the lemma `eval_instance_iff_eval`.
  have := (eval_instance_iff_eval this).mpr (hv M' w),
  exact h this,
end

/- What does this equivalence under validity mean for us? It means that we don't
actually need the notion of schema in the first place =/, because we can always
just reason about the characteristic formula. However, note that this
equivalence under validity between the schema and its characteristic
formula breaks down when we replace validity with truth in a specific model.
Consider the following counterexample: -/

/-- At least one direction holds, since A is an instance of its own schema. -/
theorem characteristic_true_of_schema_true {M : model vars}
  : (M ⊨ schema A) → (M ⊩ A) :=
begin
  intros hsA w,
  exact hsA A ⟨∅, subst.apply_empty_id⟩ w,
end

/-- but consider the following model with one world: -/
def myM : model vars := {
  F := {
    W := unit, -- one world only: the unit element ()
    R := λ _ _, false }, -- the frame relation doesn't matter
  V := λ x, {()} -- every variable is true at the one and only world ()
}

/-- This model is a counter-example for the other direction of the equivalence:
The variable p is true in myM at any world by definition of myM.V. However it
has a substitution instance ⊥ that is never true at any world. -/
theorem characteristic_true_but_schema_not_true {p : vars}
  : (myM ⊩ ⦃p⦄) ∧ (myM ⊭ schema ⦃p⦄) :=
begin
  split,
  { rintro ⟨⟩, simp only [eval], tauto }, -- hint told me to use tauto
  { simp only [eval_schema, not_forall, exists_prop],
    use ⊥,
    split,
    { use ⟨[⟨p, ⊥⟩], by simp⟩, simp [subst.apply, subst.get, alist.lookup] },
    { use ⟨⟩, simp [eval] }
  }
end

/-- Classes of models defined by a property of their frames. -/
def ℂ (F_prop : ∀ {W : Type}, (W → W → Prop) → Prop) : set (model vars) :=
{M | F_prop M.F.R}

/- The following are some example classes that contain models with particular
frame properties. -/

/-- Models with reflexive frames -/
def ℂ_reflexive : set (model vars) :=
 ℂ (λ W R, ∀ w, R w w)

/-- Models with transitive frames -/
def ℂ_transitive : set (model vars) :=
ℂ (λ W R, ∀ w1 w2 w3, R w1 w2 ∧ R w2 w3 → R w1 w3)

/-- The general class of all models -/
def ℂ_all : set (model vars) := ℂ (λ _ _, true)

/-- It is also possible to define a restricted notion of validity to classes of
models. -/
def ℂ_valid (ℂ : set (model vars)) (A : form vars) :=
∀ M ∈ ℂ, M ⊩ A

def ℂ_schema_valid (ℂ : set (model vars)) (𝕊 : set (form vars)) :=
∀ M ∈ ℂ, M ⊨ 𝕊

/-- We can modify the proof of valid_schema_iff_valid to adapt it to
class validity, but only for classes constructed by ℂ. -/
theorem class_valid_schema_iff_class_valid
{F_prop : ∀ {W : Type}, (W → W → Prop) → Prop}
: ℂ_schema_valid (ℂ @F_prop) (schema A) ↔ ℂ_valid (ℂ @F_prop) A :=
begin
  split,
  -- the mp direction is easy since A must be in its own schema.
  { intros hv M hMℂ w, exact hv M hMℂ A ⟨∅, subst.apply_empty_id⟩ w },
  rintros hv ⟨⟨W, _, R⟩, V⟩ hMℂ A' ⟨s, rfl⟩ w,
  resetI,
  by_contra h,
  -- We construct M' that re-assigns variables based on the truth value of their
  -- substitutions in the original model M.
  set V' := λ x, {w | ⟪W, R, V⟫@@w ⊩ s.get x} with hV',
  set M' : model vars := ⟪W, R, V'⟫ with hM',
  -- This wouldn't work if we use arbitrary sets as classes since we'd know
  -- nothing about what frames are included in the set. But we know that ℂ
  -- aserts some kind of property on R which we know to be preserved since we
  -- use the same R.
  have hM'ℂ : M' ∈ (@ℂ vars _ @F_prop), {
    simp only [ℂ, set.mem_set_of_eq], exact hMℂ
  },
  -- Hence, whenever the substituted formula A' holds in the original model,
  -- the pre-substituted formula A holds in our new model. This is represented
  -- by the lemma `eval_instance_iff_eval`.
  have := (eval_instance_iff_eval (congr_fun hV')).mpr (hv M' hM'ℂ w),
  exact h this,
end

/- There is a vague sense in which the formula T ≡ □ p ⟹ p "characterizes"
models with reflexive relations. Semantically T reads that if p holds in this
world, then p holds in some related world. In general, this holds iff the
accessibility relation is reflexive, since the only world we can guarantee to
have p hold is the current one. We can see one direction of the correspondence
via the following theorem of validity: for any model, if it is reflexive, then T
holds in the model. -/

theorem T_is_ℂ_valid_reflexive {p : vars}
: ℂ_valid ℂ_reflexive (□ ⦃p⦄ ⟹ ⦃p⦄) :=
begin
  unfold ℂ_valid,
  intros M hM w,
  simp only [ℂ_reflexive, ℂ, set.mem_set_of_eq] at hM,
  simp only [eval, not_forall, exists_prop, set.not_not_mem],
  intros hbA,
  exact hbA w (hM w)
end

/- However, the converse doesn't hold: when T holds in a model, it is not
necessarily reflexive. This is because we can have specific valuations that
make it trivial to prove the statement. So, the statement is true by virtue of
the valuation, not the frame. For example, in a model where the antecedent p is
never true. -/

def myM' : model vars := {
  F := {
    W := unit,
    R := λ _ _, false }, -- the frame relation is not reflexive
  V := λ x, {} -- no variable is ever true at any world
}

theorem T_true_in_non_reflexive_model {p : vars}
: (myM' ⊩ ⦃p⦄ ⟹ ◇⦃p⦄) ∧ (myM' ∉ @ℂ_reflexive vars _) :=
begin
  split,
  { rintro w ⟨⟩ }, -- ⟨⟩ : false allows to prove anything
  { simp [ℂ_reflexive, ℂ, myM'], }
end

/- This doesn't work because it is the frame relation that we care about, but
we are reasoning about classes of models. Instead, we should work with classes
of frames and work from there. This is done in src/frame_definability.lean. -/

/- The following are some small theorems about class validity. -/

theorem box_class_valid_of_class_valid {C : set (model vars)}
(hvA : ℂ_valid C A) : ℂ_valid C (□ A) :=
begin
  unfold ℂ_valid,
  intros M hMinC _,
  unfold eval,
  intros w' hrel,
  exact hvA M hMinC w',
end

theorem class_valid_subset {C C' : set (model vars)} (hsub : C' ⊆ C)
(hvA : ℂ_valid C A) : ℂ_valid C' A :=
begin
  unfold ℂ_valid,
  intros M hMinC',
  exact hvA M (hsub hMinC')
end


import data.rat.default data.pnat.basic tactic.fin_cases

/-! # IMO 2013 N6 -/

namespace IMOSL
namespace IMO2013N6

open function

def fn_eq (f : ℚ → ℤ) := ∀ (x : ℚ) (a : ℤ) (b : ℕ+), f ((x + a) / b) = f (((f x : ℚ) + a) / b)

section extra

variables {α : Type*} [linear_ordered_ring α] [floor_ring α]

lemma floor_eq_floor_iff (x y : α) : ⌊x⌋ = ⌊y⌋ ↔ (∀ k : ℤ, ↑k ≤ x ↔ ↑k ≤ y) :=
  ⟨λ h k, by rw [← int.le_floor, h, int.le_floor],
   λ h, le_antisymm (int.le_floor.mpr ((h _).mp (int.floor_le x)))
                    (int.le_floor.mpr ((h _).mpr (int.floor_le y)))⟩

end extra

section results

variables {f : ℚ → ℤ} (feq : fn_eq f)
include feq

private lemma lem1 (h : f 0 = f 1) : ∃ C : ℤ, f = const ℚ C :=
begin
  suffices : ∀ (n : ℕ) (a : ℤ) (b : ℕ+), f (a / b) = f ((a + n) / b),
  { use f 0; ext x; rw const_apply,
    induction x using rat.num_denom_cases_on with a b h0 h1,
    lift b to ℕ+ using h0,
    rw [← rat.coe_int_div_eq_mk, ← coe_coe, ← coe_coe],
    cases le_total 0 a with h0 h0,
    { lift a to ℕ using h0,
      replace h1 := this a 0 b,
      rw [int.cast_zero, zero_div, zero_add] at h1,
      rw [← coe_coe, ← h1] },
    { rw ← neg_nonneg at h0,
      lift (-a) to ℕ using h0 with x h0,
      replace h1 := this x a b,
      rw [h1, ← int.cast_coe_nat, h0, int.cast_neg, add_neg_self, zero_div] } },
  intros n; induction n with n n_ih; intros a b,
  rw [nat.cast_zero, add_zero],
  have h1 := feq 0 a b,
  rw [zero_add, h, ← feq, add_comm, ← int.cast_one, ← int.cast_add] at h1,
  rw [h1, n_ih, int.cast_add, nat.cast_succ, add_right_comm, add_assoc, int.cast_one]
end

private lemma lem2 (h : f 0 ≠ f 1) (m : ℤ) : f m = m :=
begin
  apply le_antisymm; rw ← not_lt; intros h0,
  { lift (f m - m) to ℕ+ using (by rwa sub_pos) with k h1,
    replace feq := feq m (-m) k,
    rw [← int.cast_add, add_neg_self, int.cast_zero, zero_div, ← int.cast_add,
        ← sub_eq_add_neg, ← h1, coe_coe, int.cast_coe_nat, ← coe_coe, div_self] at feq,
    exacts [h feq, by rw [coe_coe, nat.cast_ne_zero]; exact pnat.ne_zero k] },
  { lift (m - f m) to ℕ+ using (by rwa sub_pos) with k h1,
    replace feq := feq m (-f m) k,
    rw [← int.cast_add, ← sub_eq_add_neg, ← h1, coe_coe, int.cast_coe_nat, ← coe_coe,
        div_self, ← int.cast_add, add_neg_self, int.cast_zero, zero_div, eq_comm] at feq,
    exacts [h feq, by rw [coe_coe, nat.cast_ne_zero]; exact pnat.ne_zero k] }
end

private lemma lem3 (h : ∀ m : ℤ, f m = m) : f (1 / 2) = 0 ∨ f (1 / 2) = 1 :=
begin
  cases le_or_lt (f (1 / 2)) 0 with h0 h0,
  { have h1 : 0 < 1 - 2 * f (1 / 2) := by rw sub_pos;
      exact lt_of_le_of_lt (mul_nonpos_of_nonneg_of_nonpos zero_le_two h0) one_pos,
    lift 1 - 2 * f (1 / 2) to ℕ+ using h1 with b h1,
    replace feq := feq (1 / 2) (-f (1 / 2)) b,
    left; rw int.cast_neg at feq; convert feq using 2,
    rw [← sub_eq_add_neg, eq_div_iff, div_sub', coe_coe, ← int.cast_coe_nat, h1,
        int.cast_sub, int.cast_mul, int.cast_one, int.cast_two, div_mul_comm, mul_one],
    exact two_ne_zero,
    rw [coe_coe, nat.cast_ne_zero]; exact b.ne_zero,
    rw [add_neg_self, zero_div, eq_comm, ← int.cast_zero, h] },
  { have h1 : 0 < 2 * f (1 / 2) - 1 := begin
      rw [int.lt_iff_add_one_le, zero_add] at h0,
      rw [sub_pos, int.lt_iff_add_one_le, ← mul_one (1 + 1 : ℤ), ← bit0, mul_le_mul_left],
      exacts [h0, two_pos]
    end,
    lift 2 * f (1 / 2) - 1 to ℕ+ using h1 with b h1,
    replace feq := feq (1 / 2) (f (1 / 2) - 1) b,
    have h2 : (b : ℚ) ≠ 0 := by rw [coe_coe, nat.cast_ne_zero]; exact b.ne_zero,
    right; convert feq using 2,
    rw [eq_div_iff h2, div_add', coe_coe, ← int.cast_coe_nat, h1, int.cast_sub, int.cast_sub,
        sub_mul, add_sub_left_comm, int.cast_one, mul_two (1 : ℚ), int.cast_mul, sub_add_cancel',
        ← sub_eq_add_neg, int.cast_two, mul_comm (2 : ℚ), div_mul_comm, mul_one],
    exact two_ne_zero,
    rw [← int.cast_add, ← add_sub_assoc, ← two_mul, ← h1, coe_coe, int.cast_coe_nat,
        ← coe_coe b, div_self h2, eq_comm, ← int.cast_one, h] }
end

private lemma lem4 (h : ∀ m : ℤ, f m = m) (h0 : f (1 / 2) = 0)
  (a : ℕ) (b : ℕ+) (h1 : a < b) : f (a / b) = 0 :=
begin
  revert a h1; induction b using pnat.case_strong_induction_on with b b_ih; intros a h1,
  rw [pnat.one_coe, nat.lt_one_iff] at h1,
  rw [h1, nat.cast_zero, zero_div, ← int.cast_zero, h],
  rw [pnat.add_coe, pnat.one_coe, nat.lt_add_one_iff, le_iff_lt_or_eq] at h1,
  suffices : ∀ a : ℕ, a < b → f (a / ↑(b + 1)) = 0,
  { rcases h1 with h1 | rfl,
    exact this a h1,
    rcases eq_or_ne b 1 with rfl | h1,
    rw [coe_coe, pnat.add_coe, pnat.one_coe, nat.cast_add, nat.cast_one, ← bit0, h0],
    replace h1 := pnat.exists_eq_succ_of_ne_one h1,
    rcases h1 with ⟨k, rfl⟩,
    replace this := this 1 (by rw [pnat.add_coe, pnat.one_coe]; exact pnat.lt_add_left 1 k),
    rw nat.cast_one at this,
    replace feq := feq (1 / ↑(k + 1 + 1)) k (k + 1),
    replace b_ih := b_ih (k + 1) (le_refl _) k
      (by rw [pnat.add_coe, pnat.one_coe]; exact pnat.lt_add_right k 1),
    rw [this, int.cast_zero, zero_add, coe_coe k, ← coe_coe, b_ih,
        div_add', div_div, mul_comm ↑(k + 1 + 1), ← div_div] at feq,
    convert feq; rw eq_div_iff,
    simp only [pnat.one_coe, nat.cast_add, pnat.add_coe, nat.cast_one, coe_coe],
    rw [int.cast_add, int.cast_add, int.cast_one, ← coe_coe],
    generalize : ((k : ℕ) : ℚ) = m,
    rw [mul_add_one, mul_add_one, add_comm (1 : ℚ), add_assoc, mul_comm],
    all_goals { apply ne_of_gt, rw [coe_coe, nat.cast_pos], exact pnat.pos _ } },
  clear h1 a; intros a h1,
  replace feq := feq (a / b) a (b + 1),
  replace b_ih := b_ih b (le_refl b) a h1,
  suffices : ((b : ℚ)⁻¹ + 1) / ↑(b + 1) = (b : ℚ)⁻¹,
    rwa [b_ih, int.cast_zero, zero_add, ← coe_coe, div_eq_mul_inv (a : ℚ),
         ← mul_add_one, mul_div_assoc, this, ← div_eq_mul_inv, b_ih, eq_comm] at feq,
  simp only [pnat.one_coe, nat.cast_add, pnat.add_coe, nat.cast_one, coe_coe],
  rw [int.cast_add, int.cast_one, ← coe_coe],
  generalize h : ((b : ℕ) : ℚ) = k,
  replace h : 0 < k := by rw [← h, nat.cast_pos]; exact pnat.pos b,
  rw [inv_eq_one_div, div_add_one, add_comm, div_div, div_mul_left],
  exacts [ne_of_gt (add_pos h one_pos), ne_of_gt h]
end

private lemma lem5 (h : ∀ m : ℤ, f m = m) (h0 : f (1 / 2) = 0) : f = int.floor :=
begin
  suffices : ∀ x : ℚ, ⌊x⌋ = 0 → f x = 0,
  { ext x,
    replace feq := feq (x - ⌊x⌋) ⌊x⌋ 1,
    rwa [coe_coe (1 : ℕ+), pnat.one_coe, nat.cast_one, div_one, div_one,
         sub_add_cancel, this (x - ⌊x⌋), int.cast_zero, zero_add, h] at feq,
    rw [int.floor_sub_int, sub_self] },
  intros x h1,
  induction x using rat.num_denom_cases_on with a b h2 h3; clear h3,
  lift b to ℕ+ using h2,
  rw [← rat.coe_int_div_eq_mk, int.cast_coe_nat] at h1 ⊢,
  have h2 : 0 < ((b : ℕ) : ℚ) := nat.cast_pos.mpr b.pos,
  rw [int.floor_eq_iff, int.cast_zero, zero_add, div_lt_one h2, le_div_iff h2,
      zero_mul, int.cast_nonneg, ← int.cast_coe_nat, int.cast_lt, ← coe_coe] at h1,
  cases h1 with h3 h1,
  lift a to ℕ using h3,
  rw [coe_coe, nat.cast_lt] at h1,
  rw [← coe_coe, ← coe_coe, lem4 feq h h0 a b h1]
end

end results

/-- Final solution -/
theorem final_solution (f : ℚ → ℤ) : fn_eq f ↔
  ((∃ C : ℤ, f = const ℚ C) ∨ f = int.floor ∨ f = int.ceil) :=
begin
  split,
  { intros feq,
    cases eq_or_ne (f 0) (f 1) with h h,
    left; exact lem1 feq h,
    right; replace h := lem2 feq h,
    cases lem3 feq h with h0 h0,
    left; exact lem5 feq h h0,
    right; suffices : (λ x, -f (-x)) = int.floor,
    { ext x; convert congr_arg has_neg.neg (congr_fun this (-x)),
      rw [neg_neg, neg_neg] },
    refine lem5 (λ x a b, _) (λ m, _) _,
    rw [neg_inj, ← neg_div, ← neg_div, neg_add, neg_add,
        int.cast_neg, neg_neg, ← int.cast_neg, feq],
    rw [← int.cast_neg, h, neg_neg],
    rw [neg_eq_zero, ← h 0],
    convert feq (1 / 2) (-1) 1; field_simp,
    rw [bit0, neg_add, ← add_assoc, add_neg_self, zero_add],
    rw [h0, int.cast_one, add_neg_self] },
  suffices : fn_eq int.floor,
  { rintros (⟨C, rfl⟩ | rfl | rfl),
    intros x a b; rw const_apply,
    exact this,
    intros x a b,
    replace this := this (-x) (-a) b,
    rwa [int.cast_neg, ← neg_add, neg_div, int.floor_neg, int.floor_neg,
         int.cast_neg, ← neg_add, neg_div, int.floor_neg, neg_inj] at this },
  intros x a b,
  rw floor_eq_floor_iff; intros k,
  have h : 0 < (b : ℚ) := by rw [coe_coe, nat.cast_pos]; exact b.pos,
  rw [le_div_iff h, le_div_iff h, ← sub_le_iff_le_add, ← sub_le_iff_le_add, coe_coe,
      ← int.cast_coe_nat, ← coe_coe b, ← int.cast_mul, ← int.cast_sub, int.cast_le, int.le_floor]
end

end IMO2013N6
end IMOSL


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import data.matrix.basis
import linear_algebra.basis
import linear_algebra.pi

/-!
# The standard basis

This file defines the standard basis `pi.basis (s : ∀ j, basis (ι j) R (M j))`,
which is the `Σ j, ι j`-indexed basis of Π j, M j`. The basis vectors are given by
`pi.basis s ⟨j, i⟩ j' = linear_map.std_basis R M j' (s j) i = if j = j' then s i else 0`.

The standard basis on `R^η`, i.e. `η → R` is called `pi.basis_fun`.

To give a concrete example, `linear_map.std_basis R (λ (i : fin 3), R) i 1`
gives the `i`th unit basis vector in `R³`, and `pi.basis_fun R (fin 3)` proves
this is a basis over `fin 3 → R`.

## Main definitions

 - `linear_map.std_basis R M`: if `x` is a basis vector of `M i`, then
   `linear_map.std_basis R M i x` is the `i`th standard basis vector of `Π i, M i`.
 - `pi.basis s`: given a basis `s i` for each `M i`, the standard basis on `Π i, M i`
 - `pi.basis_fun R η`: the standard basis on `R^η`, i.e. `η → R`, given by
   `pi.basis_fun R η i j = if i = j then 1 else 0`.
 - `matrix.std_basis R n m`: the standard basis on `matrix n m R`, given by
   `matrix.std_basis R n m (i, j) i' j' = if (i, j) = (i', j') then 1 else 0`.

-/

open function submodule
open_locale big_operators

namespace linear_map

variables (R : Type*) {ι : Type*} [semiring R] (φ : ι → Type*)
  [Π i, add_comm_monoid (φ i)] [Π i, module R (φ i)] [decidable_eq ι]

/-- The standard basis of the product of `φ`. -/
def std_basis : Π (i : ι), φ i →ₗ[R] (Πi, φ i) := single

lemma std_basis_apply (i : ι) (b : φ i) : std_basis R φ i b = update 0 i b :=
rfl

@[simp] lemma std_basis_apply' (i i' : ι) : (std_basis R (λ (_x : ι), R) i) 1 i' =
  ite (i = i') 1 0  :=
begin
  rw [linear_map.std_basis_apply, function.update_apply, pi.zero_apply],
  congr' 1, rw [eq_iff_iff, eq_comm],
end

lemma coe_std_basis (i : ι) : ⇑(std_basis R φ i) = pi.single i :=
rfl

@[simp] lemma std_basis_same (i : ι) (b : φ i) : std_basis R φ i b i = b :=
pi.single_eq_same i b

lemma std_basis_ne (i j : ι) (h : j ≠ i) (b : φ i) : std_basis R φ i b j = 0 :=
pi.single_eq_of_ne h b

lemma std_basis_eq_pi_diag (i : ι) : std_basis R φ i = pi (diag i) :=
begin
  ext x j,
  convert (update_apply 0 x i j _).symm,
  refl,
end

lemma ker_std_basis (i : ι) : ker (std_basis R φ i) = ⊥ :=
ker_eq_bot_of_injective $ pi.single_injective _ _

lemma proj_comp_std_basis (i j : ι) : (proj i).comp (std_basis R φ j) = diag j i :=
by rw [std_basis_eq_pi_diag, proj_pi]

lemma proj_std_basis_same (i : ι) : (proj i).comp (std_basis R φ i) = id :=
linear_map.ext $ std_basis_same R φ i

lemma proj_std_basis_ne (i j : ι) (h : i ≠ j) : (proj i).comp (std_basis R φ j) = 0 :=
linear_map.ext $ std_basis_ne R φ _ _ h

lemma supr_range_std_basis_le_infi_ker_proj (I J : set ι) (h : disjoint I J) :
  (⨆i∈I, range (std_basis R φ i)) ≤ (⨅i∈J, ker (proj i : (Πi, φ i) →ₗ[R] φ i)) :=
begin
  refine (supr_le $ λ i, supr_le $ λ hi, range_le_iff_comap.2 _),
  simp only [(ker_comp _ _).symm, eq_top_iff, set_like.le_def, mem_ker, comap_infi, mem_infi],
  rintro b - j hj,
  rw [proj_std_basis_ne R φ j i, zero_apply],
  rintro rfl,
  exact h.le_bot ⟨hi, hj⟩
end

lemma infi_ker_proj_le_supr_range_std_basis {I : finset ι} {J : set ι} (hu : set.univ ⊆ ↑I ∪ J) :
  (⨅ i∈J, ker (proj i : (Πi, φ i) →ₗ[R] φ i)) ≤ (⨆i∈I, range (std_basis R φ i)) :=
set_like.le_def.2
begin
  assume b hb,
  simp only [mem_infi, mem_ker, proj_apply] at hb,
  rw ← show ∑ i in I, std_basis R φ i (b i) = b,
  { ext i,
    rw [finset.sum_apply, ← std_basis_same R φ i (b i)],
    refine finset.sum_eq_single i (assume j hjI ne, std_basis_ne _ _ _ _ ne.symm _) _,
    assume hiI,
    rw [std_basis_same],
    exact hb _ ((hu trivial).resolve_left hiI) },
  exact sum_mem_bsupr (λ i hi, mem_range_self (std_basis R φ i) (b i))
end

lemma supr_range_std_basis_eq_infi_ker_proj {I J : set ι}
  (hd : disjoint I J) (hu : set.univ ⊆ I ∪ J) (hI : set.finite I) :
  (⨆i∈I, range (std_basis R φ i)) = (⨅i∈J, ker (proj i : (Πi, φ i) →ₗ[R] φ i)) :=
begin
  refine le_antisymm (supr_range_std_basis_le_infi_ker_proj _ _ _ _ hd) _,
  have : set.univ ⊆ ↑hI.to_finset ∪ J, { rwa [hI.coe_to_finset] },
  refine le_trans (infi_ker_proj_le_supr_range_std_basis R φ this) (supr_mono $ assume i, _),
  rw [set.finite.mem_to_finset],
  exact le_rfl
end

lemma supr_range_std_basis [finite ι] : (⨆ i, range (std_basis R φ i)) = ⊤ :=
begin
  casesI nonempty_fintype ι,
  convert top_unique (infi_emptyset.ge.trans $ infi_ker_proj_le_supr_range_std_basis R φ _),
  { exact funext (λ i, (@supr_pos _ _ _ (λ h, range $ std_basis R φ i) $ finset.mem_univ i).symm) },
  { rw [finset.coe_univ, set.union_empty] }
end

lemma disjoint_std_basis_std_basis (I J : set ι) (h : disjoint I J) :
  disjoint (⨆i∈I, range (std_basis R φ i)) (⨆i∈J, range (std_basis R φ i)) :=
begin
  refine disjoint.mono
    (supr_range_std_basis_le_infi_ker_proj _ _ _ _ $ disjoint_compl_right)
    (supr_range_std_basis_le_infi_ker_proj _ _ _ _ $ disjoint_compl_right) _,
  simp only [disjoint_iff_inf_le, set_like.le_def, mem_infi, mem_inf, mem_ker, mem_bot, proj_apply,
    funext_iff],
  rintros b ⟨hI, hJ⟩ i,
  classical,
  by_cases hiI : i ∈ I,
  { by_cases hiJ : i ∈ J,
    { exact (h.le_bot ⟨hiI, hiJ⟩).elim },
    { exact hJ i hiJ } },
  { exact hI i hiI }
end

lemma std_basis_eq_single {a : R} :
  (λ (i : ι), (std_basis R (λ _ : ι, R) i) a) = λ (i : ι), (finsupp.single i a) :=
funext $ λ i, (finsupp.single_eq_pi_single i a).symm

end linear_map

namespace pi
open linear_map
open set

variables {R : Type*}

section module
variables {η : Type*} {ιs : η → Type*} {Ms : η → Type*}

lemma linear_independent_std_basis [ring R] [∀i, add_comm_group (Ms i)] [∀i, module R (Ms i)]
  [decidable_eq η] (v : Πj, ιs j → (Ms j)) (hs : ∀i, linear_independent R (v i)) :
  linear_independent R (λ (ji : Σ j, ιs j), std_basis R Ms ji.1 (v ji.1 ji.2)) :=
begin
  have hs' : ∀j : η, linear_independent R (λ i : ιs j, std_basis R Ms j (v j i)),
  { intro j,
    exact (hs j).map' _ (ker_std_basis _ _ _) },
  apply linear_independent_Union_finite hs',
  { assume j J _ hiJ,
    simp [(set.Union.equations._eqn_1 _).symm, submodule.span_image, submodule.span_Union],
    have h₀ : ∀ j, span R (range (λ (i : ιs j), std_basis R Ms j (v j i)))
        ≤ range (std_basis R Ms j),
    { intro j,
      rw [span_le, linear_map.range_coe],
      apply range_comp_subset_range },
    have h₁ : span R (range (λ (i : ιs j), std_basis R Ms j (v j i)))
        ≤ ⨆ i ∈ {j}, range (std_basis R Ms i),
    { rw @supr_singleton _ _ _ (λ i, linear_map.range (std_basis R (λ (j : η), Ms j) i)),
      apply h₀ },
    have h₂ : (⨆ j ∈ J, span R (range (λ (i : ιs j), std_basis R Ms j (v j i)))) ≤
               ⨆ j ∈ J, range (std_basis R (λ (j : η), Ms j) j) :=
      supr₂_mono (λ i _, h₀ i),
    have h₃ : disjoint (λ (i : η), i ∈ {j}) J,
    { convert set.disjoint_singleton_left.2 hiJ using 0 },
    exact (disjoint_std_basis_std_basis _ _ _ _ h₃).mono h₁ h₂ }
end

variables [semiring R] [∀i, add_comm_monoid (Ms i)] [∀i, module R (Ms i)]

variable [fintype η]

section

open linear_equiv

/-- `pi.basis (s : ∀ j, basis (ιs j) R (Ms j))` is the `Σ j, ιs j`-indexed basis on `Π j, Ms j`
given by `s j` on each component.

For the standard basis over `R` on the finite-dimensional space `η → R` see `pi.basis_fun`.
-/
protected noncomputable def basis (s : ∀ j, basis (ιs j) R (Ms j)) :
  basis (Σ j, ιs j) R (Π j, Ms j) :=
-- The `add_comm_monoid (Π j, Ms j)` instance was hard to find.
-- Defining this in tactic mode seems to shake up instance search enough that it works by itself.
by { refine basis.of_repr (_ ≪≫ₗ (finsupp.sigma_finsupp_lequiv_pi_finsupp R).symm),
     exact linear_equiv.Pi_congr_right (λ j, (s j).repr) }

@[simp] lemma basis_repr_std_basis [decidable_eq η] (s : ∀ j, basis (ιs j) R (Ms j)) (j i) :
  (pi.basis s).repr (std_basis R _ j (s j i)) = finsupp.single ⟨j, i⟩ 1 :=
begin
  ext ⟨j', i'⟩,
  by_cases hj : j = j',
  { subst hj,
    simp only [pi.basis, linear_equiv.trans_apply, basis.repr_self, std_basis_same,
        linear_equiv.Pi_congr_right_apply, finsupp.sigma_finsupp_lequiv_pi_finsupp_symm_apply],
    symmetry,
    exact finsupp.single_apply_left
      (λ i i' (h : (⟨j, i⟩ : Σ j, ιs j) = ⟨j, i'⟩), eq_of_heq (sigma.mk.inj h).2) _ _ _ },
  simp only [pi.basis, linear_equiv.trans_apply, finsupp.sigma_finsupp_lequiv_pi_finsupp_symm_apply,
      linear_equiv.Pi_congr_right_apply],
  dsimp,
  rw [std_basis_ne _ _ _ _ (ne.symm hj), linear_equiv.map_zero, finsupp.zero_apply,
      finsupp.single_eq_of_ne],
  rintros ⟨⟩,
  contradiction
end

@[simp] lemma basis_apply [decidable_eq η] (s : ∀ j, basis (ιs j) R (Ms j)) (ji) :
  pi.basis s ji = std_basis R _ ji.1 (s ji.1 ji.2) :=
basis.apply_eq_iff.mpr (by simp)

@[simp] lemma basis_repr (s : ∀ j, basis (ιs j) R (Ms j)) (x) (ji) :
  (pi.basis s).repr x ji = (s ji.1).repr (x ji.1) ji.2 :=
rfl

end

section
variables (R η)

/-- The basis on `η → R` where the `i`th basis vector is `function.update 0 i 1`. -/
noncomputable def basis_fun : basis η R (Π (j : η), R) :=
basis.of_equiv_fun (linear_equiv.refl _ _)

@[simp] lemma basis_fun_apply [decidable_eq η] (i) :
  basis_fun R η i = std_basis R (λ (i : η), R) i 1 :=
by { simp only [basis_fun, basis.coe_of_equiv_fun, linear_equiv.refl_symm,
                linear_equiv.refl_apply, std_basis_apply] }

@[simp] lemma basis_fun_repr (x : η → R) (i : η) :
  (pi.basis_fun R η).repr x i = x i :=
by simp [basis_fun]

end

end module

end pi

namespace matrix

variables (R : Type*) (m n : Type*) [fintype m] [fintype n] [semiring R]

/-- The standard basis of `matrix m n R`. -/
noncomputable def std_basis : basis (m × n) R (matrix m n R) :=
basis.reindex (pi.basis (λ (i : m), pi.basis_fun R n)) (equiv.sigma_equiv_prod _ _)

variables {n m}

lemma std_basis_eq_std_basis_matrix (i : n) (j : m) [decidable_eq n] [decidable_eq m] :
  std_basis R n m (i, j) = std_basis_matrix i j (1 : R) :=
begin
  ext a b,
  by_cases hi : i = a; by_cases hj : j = b,
  { simp [std_basis, hi, hj] },
  { simp [std_basis, hi, hj, ne.symm hj, linear_map.std_basis_ne] },
  { simp [std_basis, hi, hj, ne.symm hi, linear_map.std_basis_ne] },
  { simp [std_basis, hi, hj, ne.symm hj, ne.symm hi, linear_map.std_basis_ne] }
end

end matrix


/-
Copyright (c) 2019 Johan Commelin All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import order.filter.lift
import topology.opens
import topology.algebra.ring

open topological_space
open_locale topological_space

set_option old_structure_cmd true

/-- The type of open subgroups of a topological additive group. -/
@[ancestor add_subgroup]
structure open_add_subgroup  (G : Type*) [add_group G] [topological_space G]
  extends add_subgroup G :=
(is_open' : is_open carrier)

/-- The type of open subgroups of a topological group. -/
@[ancestor subgroup, to_additive]
structure open_subgroup (G : Type*) [group G] [topological_space G] extends subgroup G :=
(is_open' : is_open carrier)

/-- Reinterpret an `open_subgroup` as a `subgroup`. -/
add_decl_doc open_subgroup.to_subgroup

/-- Reinterpret an `open_add_subgroup` as an `add_subgroup`. -/
add_decl_doc open_add_subgroup.to_add_subgroup

-- Tell Lean that `open_add_subgroup` is a namespace
namespace open_add_subgroup
end open_add_subgroup

namespace open_subgroup
open function topological_space
variables {G : Type*} [group G] [topological_space G]
variables {U V : open_subgroup G} {g : G}

@[to_additive]
instance has_coe_set : has_coe_t (open_subgroup G) (set G) := ⟨λ U, U.1⟩

@[to_additive]
instance : has_mem G (open_subgroup G) := ⟨λ g U, g ∈ (U : set G)⟩

@[to_additive]
instance has_coe_subgroup : has_coe_t (open_subgroup G) (subgroup G) := ⟨to_subgroup⟩

@[to_additive]
instance has_coe_opens : has_coe_t (open_subgroup G) (opens G) := ⟨λ U, ⟨U, U.is_open'⟩⟩

@[simp, to_additive] lemma mem_coe : g ∈ (U : set G) ↔ g ∈ U := iff.rfl
@[simp, to_additive] lemma mem_coe_opens : g ∈ (U : opens G) ↔ g ∈ U := iff.rfl
@[simp, to_additive]
lemma mem_coe_subgroup : g ∈ (U : subgroup G) ↔ g ∈ U := iff.rfl

attribute [norm_cast] mem_coe mem_coe_opens mem_coe_subgroup open_add_subgroup.mem_coe
  open_add_subgroup.mem_coe_opens open_add_subgroup.mem_coe_add_subgroup

@[to_additive] lemma coe_injective : injective (coe : open_subgroup G → set G) :=
λ U V h, by cases U; cases V; congr; assumption

@[ext, to_additive]
lemma ext (h : ∀ x, x ∈ U ↔ x ∈ V) : (U = V) := coe_injective $ set.ext h

@[to_additive]
lemma ext_iff : (U = V) ↔ (∀ x, x ∈ U ↔ x ∈ V) := ⟨λ h x, h ▸ iff.rfl, ext⟩

variable (U)
@[to_additive]
protected lemma is_open : is_open (U : set G) := U.is_open'

@[to_additive]
protected lemma one_mem : (1 : G) ∈ U := U.one_mem'

@[to_additive]
protected lemma inv_mem {g : G} (h : g ∈ U) : g⁻¹ ∈ U := U.inv_mem' h

@[to_additive]
protected lemma mul_mem {g₁ g₂ : G} (h₁ : g₁ ∈ U) (h₂ : g₂ ∈ U) : g₁ * g₂ ∈ U := U.mul_mem' h₁ h₂

@[to_additive]
lemma mem_nhds_one : (U : set G) ∈ 𝓝 (1 : G) :=
mem_nhds_sets U.is_open U.one_mem
variable {U}

@[to_additive]
instance : has_top (open_subgroup G) := ⟨{ is_open' := is_open_univ, .. (⊤ : subgroup G) }⟩

@[to_additive]
instance : inhabited (open_subgroup G) := ⟨⊤⟩

@[to_additive]
lemma is_closed [has_continuous_mul G] (U : open_subgroup G) : is_closed (U : set G) :=
begin
  apply is_open_compl_iff.1,
  refine is_open_iff_forall_mem_open.2 (λ x hx, ⟨(λ y, y * x⁻¹) ⁻¹' U, _, _, _⟩),
  { intros u hux,
    simp only [set.mem_preimage, set.mem_compl_iff, mem_coe] at hux hx ⊢,
    refine mt (λ hu, _) hx,
    convert U.mul_mem (U.inv_mem hux) hu,
    simp },
  { exact U.is_open.preimage (continuous_mul_right _) },
  { simp [U.one_mem] }
end

section
variables {H : Type*} [group H] [topological_space H]

/-- The product of two open subgroups as an open subgroup of the product group. -/
@[to_additive "The product of two open subgroups as an open subgroup of the product group."]
def prod (U : open_subgroup G) (V : open_subgroup H) : open_subgroup (G × H) :=
{ carrier := (U : set G).prod (V : set H),
  is_open' := U.is_open.prod V.is_open,
  .. (U : subgroup G).prod (V : subgroup H) }

end

@[to_additive]
instance : partial_order (open_subgroup G) :=
{ le := λ U V, ∀ ⦃x⦄, x ∈ U → x ∈ V,
  .. partial_order.lift (coe : open_subgroup G → set G) coe_injective }

@[to_additive]
instance : semilattice_inf_top (open_subgroup G) :=
{ inf := λ U V, { is_open' := is_open_inter U.is_open V.is_open, .. (U : subgroup G) ⊓ V },
  inf_le_left := λ U V, set.inter_subset_left _ _,
  inf_le_right := λ U V, set.inter_subset_right _ _,
  le_inf := λ U V W hV hW, set.subset_inter hV hW,
  top := ⊤,
  le_top := λ U, set.subset_univ _,
  ..open_subgroup.partial_order }

@[simp, to_additive] lemma coe_inf : (↑(U ⊓ V) : set G) = (U : set G) ∩ V := rfl

@[simp, to_additive] lemma coe_subset : (U : set G) ⊆ V ↔ U ≤ V := iff.rfl

@[simp, to_additive] lemma coe_subgroup_le : (U : subgroup G) ≤ (V : subgroup G) ↔ U ≤ V := iff.rfl

attribute [norm_cast] coe_inf coe_subset coe_subgroup_le open_add_subgroup.coe_inf
  open_add_subgroup.coe_subset open_add_subgroup.coe_add_subgroup_le

variables {N : Type*} [group N] [topological_space N]

/-- The preimage of an `open_subgroup` along a continuous `monoid` homomorphism
  is an `open_subgroup`. -/
@[to_additive "The preimage of an `open_add_subgroup` along a continuous `add_monoid` homomorphism
is an `open_add_subgroup`."]
def comap (f : G →* N)
  (hf : continuous f) (H : open_subgroup N) : open_subgroup G :=
{ is_open' := H.is_open.preimage hf,
  .. (H : subgroup N).comap f }

@[simp, to_additive]
lemma coe_comap (H : open_subgroup N) (f : G →* N) (hf : continuous f) :
  (H.comap f hf : set G) = f ⁻¹' H := rfl

@[simp, to_additive]
lemma mem_comap {H : open_subgroup N} {f : G →* N} {hf : continuous f} {x : G} :
  x ∈ H.comap f hf ↔ f x ∈ H := iff.rfl

@[to_additive]
lemma comap_comap {P : Type*} [group P] [topological_space P]
  (K : open_subgroup P) (f₂ : N →* P) (hf₂ : continuous f₂) (f₁ : G →* N) (hf₁ : continuous f₁) :
  (K.comap f₂ hf₂).comap f₁ hf₁ = K.comap (f₂.comp f₁) (hf₂.comp hf₁) :=
rfl

end open_subgroup

namespace subgroup

variables {G : Type*} [group G] [topological_space G] [has_continuous_mul G] (H : subgroup G)

@[to_additive]
lemma is_open_of_mem_nhds {g : G} (hg : (H : set G) ∈ 𝓝 g) :
  is_open (H : set G) :=
begin
  simp only [is_open_iff_mem_nhds, set_like.mem_coe] at hg ⊢,
  intros x hx,
  have : filter.tendsto (λ y, y * (x⁻¹ * g)) (𝓝 x) (𝓝 $ x * (x⁻¹ * g)) :=
    (continuous_id.mul continuous_const).tendsto _,
  rw [mul_inv_cancel_left] at this,
  have := filter.mem_map.1 (this hg),
  replace hg : g ∈ H := set_like.mem_coe.1 (mem_of_nhds hg),
  simp only [set_like.mem_coe, H.mul_mem_cancel_right (H.mul_mem (H.inv_mem hx) hg)] at this,
  exact this
end

@[to_additive]
lemma is_open_of_open_subgroup {U : open_subgroup G} (h : U.1 ≤ H) :
  is_open (H : set G) :=
H.is_open_of_mem_nhds (filter.mem_sets_of_superset U.mem_nhds_one h)

@[to_additive]

end subgroup

namespace open_subgroup

variables {G : Type*} [group G] [topological_space G] [has_continuous_mul G]

@[to_additive]
instance : semilattice_sup_top (open_subgroup G) :=
{ sup := λ U V,
  { is_open' := show is_open (((U : subgroup G) ⊔ V : subgroup G) : set G),
    from subgroup.is_open_mono le_sup_left U.is_open,
    .. ((U : subgroup G) ⊔ V) },
  le_sup_left := λ U V, coe_subgroup_le.1 le_sup_left,
  le_sup_right := λ U V, coe_subgroup_le.1 le_sup_right,
  sup_le := λ U V W hU hV, coe_subgroup_le.1 (sup_le hU hV),
  ..open_subgroup.semilattice_inf_top }

end open_subgroup

namespace submodule
open open_add_subgroup
variables {R : Type*} {M : Type*} [comm_ring R]
variables [add_comm_group M] [topological_space M] [topological_add_group M] [module R M]

lemma is_open_mono {U P : submodule R M} (h : U ≤ P) (hU : is_open (U : set M)) :
  is_open (P : set M) :=
@add_subgroup.is_open_mono M _ _ _ U.to_add_subgroup P.to_add_subgroup h hU

end submodule

namespace ideal
variables {R : Type*} [comm_ring R]
variables [topological_space R] [topological_ring R]

lemma is_open_of_open_subideal {U I : ideal R} (h : U ≤ I) (hU : is_open (U : set R)) :
  is_open (I : set R) :=
submodule.is_open_mono h hU

end ideal


/-
Copyright (c) 2020 Kenji Nakagawa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenji Nakagawa, Anne Baanen, Filippo A. E. Nuccio

! This file was ported from Lean 3 source module ring_theory.dedekind_domain.dvr
! leanprover-community/mathlib commit 926daa81fd8acb2a04e15572c4ff20af2753c2ae
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.DedekindDomain.Ideal
import Mathbin.RingTheory.DiscreteValuationRing
import Mathbin.RingTheory.Localization.AtPrime
import Mathbin.RingTheory.Localization.Submodule
import Mathbin.RingTheory.Valuation.Tfae

/-!
# Dedekind domains

This file defines an equivalent notion of a Dedekind domain (or Dedekind ring),
namely a Noetherian integral domain where the localization at all nonzero prime ideals is a DVR
(TODO: and shows that implies the main definition).

## Main definitions

 - `is_dedekind_domain_dvr` alternatively defines a Dedekind domain as an integral domain that
   is Noetherian, and the localization at every nonzero prime ideal is a DVR.

## Main results
 - `is_localization.at_prime.discrete_valuation_ring_of_dedekind_domain` shows that
   `is_dedekind_domain` implies the localization at each nonzero prime ideal is a DVR.
 - `is_dedekind_domain.is_dedekind_domain_dvr` is one direction of the equivalence of definitions
   of a Dedekind domain

## Implementation notes

The definitions that involve a field of fractions choose a canonical field of fractions,
but are independent of that choice. The `..._iff` lemmas express this independence.

Often, definitions assume that Dedekind domains are not fields. We found it more practical
to add a `(h : ¬ is_field A)` assumption whenever this is explicitly needed.

## References

* [D. Marcus, *Number Fields*][marcus1977number]
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]
* [J. Neukirch, *Algebraic Number Theory*][Neukirch1992]

## Tags

dedekind domain, dedekind ring
-/

variable (R A K : Type _) [CommRing R] [CommRing A] [IsDomain A] [Field K]

open nonZeroDivisors Polynomial

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (P «expr ≠ » («expr⊥»() : ideal[ideal] A)) -/
/-- A Dedekind domain is an integral domain that is Noetherian, and the
localization at every nonzero prime is a discrete valuation ring.

This is equivalent to `is_dedekind_domain`.
TODO: prove the equivalence.
-/
structure IsDedekindDomainDvr : Prop where
  IsNoetherianRing : IsNoetherianRing A
  is_dvr_at_nonzero_prime :
    ∀ (P) (_ : P ≠ (⊥ : Ideal A)), P.IsPrime → DiscreteValuationRing (Localization.AtPrime P)
#align is_dedekind_domain_dvr IsDedekindDomainDvr

/-- Localizing a domain of Krull dimension `≤ 1` gives another ring of Krull dimension `≤ 1`.

Note that the same proof can/should be generalized to preserving any Krull dimension,
once we have a suitable definition.
-/
theorem Ring.DimensionLeOne.localization {R : Type _} (Rₘ : Type _) [CommRing R] [IsDomain R]
    [CommRing Rₘ] [Algebra R Rₘ] {M : Submonoid R} [IsLocalization M Rₘ] (hM : M ≤ R⁰)
    (h : Ring.DimensionLeOne R) : Ring.DimensionLeOne Rₘ :=
  by
  intro p hp0 hpp
  refine' ideal.is_maximal_def.mpr ⟨hpp.ne_top, Ideal.maximal_of_no_maximal fun P hpP hPm => _⟩
  have hpP' : (⟨p, hpp⟩ : { p : Ideal Rₘ // p.IsPrime }) < ⟨P, hPm.is_prime⟩ := hpP
  rw [← (IsLocalization.orderIsoOfPrime M Rₘ).lt_iff_lt] at hpP'
  haveI : Ideal.IsPrime (Ideal.comap (algebraMap R Rₘ) p) :=
    ((IsLocalization.orderIsoOfPrime M Rₘ) ⟨p, hpp⟩).2.1
  haveI : Ideal.IsPrime (Ideal.comap (algebraMap R Rₘ) P) :=
    ((IsLocalization.orderIsoOfPrime M Rₘ) ⟨P, hPm.is_prime⟩).2.1
  have hlt : Ideal.comap (algebraMap R Rₘ) p < Ideal.comap (algebraMap R Rₘ) P := hpP'
  refine' h.not_lt_lt ⊥ (Ideal.comap _ _) (Ideal.comap _ _) ⟨_, hpP'⟩
  exact IsLocalization.bot_lt_comap_prime _ _ hM _ hp0
#align ring.dimension_le_one.localization Ring.DimensionLeOne.localization

/-- The localization of a Dedekind domain is a Dedekind domain. -/
theorem IsLocalization.isDedekindDomain [IsDedekindDomain A] {M : Submonoid A} (hM : M ≤ A⁰)
    (Aₘ : Type _) [CommRing Aₘ] [IsDomain Aₘ] [Algebra A Aₘ] [IsLocalization M Aₘ] :
    IsDedekindDomain Aₘ :=
  by
  have : ∀ y : M, IsUnit (algebraMap A (FractionRing A) y) :=
    by
    rintro ⟨y, hy⟩
    exact IsUnit.mk0 _ (mt is_fraction_ring.to_map_eq_zero_iff.mp (nonZeroDivisors.ne_zero (hM hy)))
  letI : Algebra Aₘ (FractionRing A) := RingHom.toAlgebra (IsLocalization.lift this)
  haveI : IsScalarTower A Aₘ (FractionRing A) :=
    IsScalarTower.of_algebraMap_eq fun x => (IsLocalization.lift_eq this x).symm
  haveI : IsFractionRing Aₘ (FractionRing A) :=
    IsFractionRing.isFractionRing_of_isDomain_of_isLocalization M _ _
  refine' (isDedekindDomain_iff _ (FractionRing A)).mpr ⟨_, _, _⟩
  · exact IsLocalization.isNoetherianRing M _ (by infer_instance)
  · exact is_dedekind_domain.dimension_le_one.localization Aₘ hM
  · intro x hx
    obtain ⟨⟨y, y_mem⟩, hy⟩ := hx.exists_multiple_integral_of_is_localization M _
    obtain ⟨z, hz⟩ := (isIntegrallyClosed_iff _).mp IsDedekindDomain.isIntegrallyClosed hy
    refine' ⟨IsLocalization.mk' Aₘ z ⟨y, y_mem⟩, (IsLocalization.lift_mk'_spec _ _ _ _).mpr _⟩
    rw [hz, [anonymous], ← Algebra.smul_def]
    rfl
#align is_localization.is_dedekind_domain IsLocalization.isDedekindDomain

/-- The localization of a Dedekind domain at every nonzero prime ideal is a Dedekind domain. -/
theorem IsLocalization.AtPrime.isDedekindDomain [IsDedekindDomain A] (P : Ideal A) [P.IsPrime]
    (Aₘ : Type _) [CommRing Aₘ] [IsDomain Aₘ] [Algebra A Aₘ] [IsLocalization.AtPrime Aₘ P] :
    IsDedekindDomain Aₘ :=
  IsLocalization.isDedekindDomain A P.primeCompl_le_nonZeroDivisors Aₘ
#align is_localization.at_prime.is_dedekind_domain IsLocalization.AtPrime.isDedekindDomain

theorem IsLocalization.AtPrime.not_isField {P : Ideal A} (hP : P ≠ ⊥) [pP : P.IsPrime] (Aₘ : Type _)
    [CommRing Aₘ] [Algebra A Aₘ] [IsLocalization.AtPrime Aₘ P] : ¬IsField Aₘ :=
  by
  intro h
  letI := h.to_field
  obtain ⟨x, x_mem, x_ne⟩ := P.ne_bot_iff.mp hP
  exact
    (LocalRing.maximalIdeal.isMaximal _).ne_top
      (Ideal.eq_top_of_isUnit_mem _
        ((IsLocalization.AtPrime.to_map_mem_maximal_iff Aₘ P _).mpr x_mem)
        (is_unit_iff_ne_zero.mpr
          ((map_ne_zero_iff (algebraMap A Aₘ)
                (IsLocalization.injective Aₘ P.prime_compl_le_non_zero_divisors)).mpr
            x_ne)))
#align is_localization.at_prime.not_is_field IsLocalization.AtPrime.not_isField

/-- In a Dedekind domain, the localization at every nonzero prime ideal is a DVR. -/
theorem IsLocalization.AtPrime.discreteValuationRing_of_dedekind_domain [IsDedekindDomain A]
    {P : Ideal A} (hP : P ≠ ⊥) [pP : P.IsPrime] (Aₘ : Type _) [CommRing Aₘ] [IsDomain Aₘ]
    [Algebra A Aₘ] [IsLocalization.AtPrime Aₘ P] : DiscreteValuationRing Aₘ := by
  classical
    letI : IsNoetherianRing Aₘ :=
      IsLocalization.isNoetherianRing P.prime_compl _ IsDedekindDomain.isNoetherianRing
    letI : LocalRing Aₘ := IsLocalization.AtPrime.localRing Aₘ P
    have hnf := IsLocalization.AtPrime.not_isField A hP Aₘ
    exact
      ((DiscreteValuationRing.tFAE Aₘ hnf).out 0 2).mpr
        (IsLocalization.AtPrime.isDedekindDomain A P _)
#align is_localization.at_prime.discrete_valuation_ring_of_dedekind_domain IsLocalization.AtPrime.discreteValuationRing_of_dedekind_domain

/-- Dedekind domains, in the sense of Noetherian integrally closed domains of Krull dimension ≤ 1,
are also Dedekind domains in the sense of Noetherian domains where the localization at every
nonzero prime ideal is a DVR. -/
theorem IsDedekindDomain.isDedekindDomainDvr [IsDedekindDomain A] : IsDedekindDomainDvr A :=
  { IsNoetherianRing := IsDedekindDomain.isNoetherianRing
    is_dvr_at_nonzero_prime := fun P hP pP =>
      IsLocalization.AtPrime.discreteValuationRing_of_dedekind_domain A hP _ }
#align is_dedekind_domain.is_dedekind_domain_dvr IsDedekindDomain.isDedekindDomainDvr